Theory CZH_UCAT_Introduction

(* Copyright 2021 (C) Mihails Milehins *)

section‹Introduction›
theory CZH_UCAT_Introduction
  imports CZH_Elementary_Categories.CZH_ECAT_Introduction
begin

text‹
This article provides a formalization of further elements of the 
theory of 1-categories without an additional structure.
More specifically, this article explores canonical universal
constructions \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/universal+construction}
} and their properties.
›

text‹\newpage›

end

Theory CZH_UCAT_Universal

(* Copyright 2021 (C) Mihails Milehins *)

section‹Universal arrow›
theory CZH_UCAT_Universal
  imports 
    CZH_UCAT_Introduction
    CZH_Elementary_Categories.CZH_ECAT_FUNCT
    CZH_Elementary_Categories.CZH_ECAT_Set
    CZH_Elementary_Categories.CZH_ECAT_Hom
begin



subsection‹Background›


text‹
The following section is based, primarily, on the elements of the content 
of Chapter III-1 in \cite{mac_lane_categories_2010}.
›



subsection‹Universal map›


text‹
The universal map is a convenience utility that allows treating 
a part of the definition of the universal arrow as an arrow in the
category Set›.
›


subsubsection‹Definition and elementary properties›

definition umap_of :: "V  V  V  V  V  V"
  where "umap_of 𝔉 c r u d =
    [
      (λf'Hom (𝔉HomDom) r d. 𝔉ArrMapf' A𝔉HomCod u),
      Hom (𝔉HomDom) r d,
      Hom (𝔉HomCod) c (𝔉ObjMapd)
    ]"

definition umap_fo :: "V  V  V  V  V  V"
  where "umap_fo 𝔉 c r u d = umap_of (op_cf 𝔉) c r u d"


text‹Components.›

lemma (in is_functor) umap_of_components:
  assumes "u : c 𝔅 𝔉ObjMapr" (*do not remove*)
  shows "umap_of 𝔉 c r u dArrVal = (λf'Hom 𝔄 r d. 𝔉ArrMapf' A𝔅 u)"
    and "umap_of 𝔉 c r u dArrDom = Hom 𝔄 r d"
    and "umap_of 𝔉 c r u dArrCod = Hom 𝔅 c (𝔉ObjMapd)"
  unfolding umap_of_def arr_field_simps
  by (simp_all add: cat_cs_simps nat_omega_simps)

lemma (in is_functor) umap_fo_components:
  assumes "u : 𝔉ObjMapr 𝔅 c"
  shows "umap_fo 𝔉 c r u dArrVal = (λf'Hom 𝔄 d r. u A𝔅 𝔉ArrMapf')"
    and "umap_fo 𝔉 c r u dArrDom = Hom 𝔄 d r"
    and "umap_fo 𝔉 c r u dArrCod = Hom 𝔅 (𝔉ObjMapd) c"
  unfolding 
    umap_fo_def 
    is_functor.umap_of_components[
      OF is_functor_op, unfolded cat_op_simps, OF assms
      ] 
proof(rule vsv_eqI)
  fix f' assume "f'  𝒟 (λf'Hom 𝔄 d r. 𝔉ArrMapf' Aop_cat 𝔅 u)"
  then have f': "f' : d 𝔄 r" by simp
  then have 𝔉f': "𝔉ArrMapf' : 𝔉ObjMapd 𝔅 𝔉ObjMapr" 
    by (auto intro: cat_cs_intros)
  from f' show 
    "(λf'Hom 𝔄 d r. 𝔉ArrMapf' Aop_cat 𝔅 u)f' = 
      (λf'Hom 𝔄 d r. u A𝔅 𝔉ArrMapf')f'"
    by (simp add: HomCod.op_cat_Comp[OF assms 𝔉f'])
qed simp_all


text‹Universal maps for the opposite functor.›

lemma (in is_functor) op_umap_of[cat_op_simps]: "umap_of (op_cf 𝔉) = umap_fo 𝔉"
  unfolding umap_fo_def by simp 

lemma (in is_functor) op_umap_fo[cat_op_simps]: "umap_fo (op_cf 𝔉) = umap_of 𝔉"
  unfolding umap_fo_def by (simp add: cat_op_simps)

lemmas [cat_op_simps] = 
  is_functor.op_umap_of
  is_functor.op_umap_fo


subsubsection‹Arrow value›

lemma umap_of_ArrVal_vsv[cat_cs_intros]: "vsv (umap_of 𝔉 c r u dArrVal)"
  unfolding umap_of_def arr_field_simps by (simp add: nat_omega_simps)

lemma umap_fo_ArrVal_vsv[cat_cs_intros]: "vsv (umap_fo 𝔉 c r u dArrVal)"
  unfolding umap_fo_def by (rule umap_of_ArrVal_vsv)

lemma (in is_functor) umap_of_ArrVal_vdomain: 
  assumes "u : c 𝔅 𝔉ObjMapr"
  shows "𝒟 (umap_of 𝔉 c r u dArrVal) = Hom 𝔄 r d"
  unfolding umap_of_components[OF assms] by simp

lemmas [cat_cs_simps] = is_functor.umap_of_ArrVal_vdomain

lemma (in is_functor) umap_fo_ArrVal_vdomain:
  assumes "u : 𝔉ObjMapr 𝔅 c"
  shows "𝒟 (umap_fo 𝔉 c r u dArrVal) = Hom 𝔄 d r"
  unfolding umap_fo_components[OF assms] by simp

lemmas [cat_cs_simps] = is_functor.umap_fo_ArrVal_vdomain

lemma (in is_functor) umap_of_ArrVal_app: 
  assumes "f' : r 𝔄 d" and "u : c 𝔅 𝔉ObjMapr"
  shows "umap_of 𝔉 c r u dArrValf' = 𝔉ArrMapf' A𝔅 u"
  using assms(1) unfolding umap_of_components[OF assms(2)] by simp

lemmas [cat_cs_simps] = is_functor.umap_of_ArrVal_app

lemma (in is_functor) umap_fo_ArrVal_app: 
  assumes "f' : d 𝔄 r" and "u : 𝔉ObjMapr 𝔅 c"
  shows "umap_fo 𝔉 c r u dArrValf' = u A𝔅 𝔉ArrMapf'"
proof-
  from assms have "𝔉ArrMapf' : 𝔉ObjMapd 𝔅 𝔉ObjMapr" 
    by (auto intro: cat_cs_intros)
  from this assms(2) have 𝔉f'[simp]:
    "𝔉ArrMapf' Aop_cat 𝔅 u = u A𝔅 𝔉ArrMapf'"
    by (simp add: cat_op_simps)
  from
    is_functor_axioms
    is_functor.umap_of_ArrVal_app[
      OF is_functor_op, unfolded cat_op_simps, 
      OF assms
      ] 
  show ?thesis
    by (simp add: cat_op_simps cat_cs_simps)
qed

lemmas [cat_cs_simps] = is_functor.umap_fo_ArrVal_app

lemma (in is_functor) umap_of_ArrVal_vrange: 
  assumes "u : c 𝔅 𝔉ObjMapr"
  shows " (umap_of 𝔉 c r u dArrVal)  Hom 𝔅 c (𝔉ObjMapd)"
proof(intro vsubset_antisym vsubsetI)
  interpret vsv ‹umap_of 𝔉 c r u dArrVal 
    unfolding umap_of_components[OF assms] by simp
  fix g assume "g   (umap_of 𝔉 c r u dArrVal)"
  then obtain f' 
    where g_def: "g = umap_of 𝔉 c r u dArrValf'" 
      and f': "f'  𝒟 (umap_of 𝔉 c r u dArrVal)"
    unfolding umap_of_components[OF assms] by auto
  then have f': "f' : r 𝔄 d" 
    unfolding umap_of_ArrVal_vdomain[OF assms] by simp
  then have 𝔉f': "𝔉ArrMapf' : 𝔉ObjMapr 𝔅 𝔉ObjMapd" 
    by (auto intro!: cat_cs_intros)
  have g_def: "g = 𝔉ArrMapf' A𝔅 u"
    unfolding g_def umap_of_ArrVal_app[OF f' assms]..
  from 𝔉f' assms show "g  Hom 𝔅 c (𝔉ObjMapd)" 
    unfolding g_def by (auto intro: cat_cs_intros)
qed

lemma (in is_functor) umap_fo_ArrVal_vrange: 
  assumes "u : 𝔉ObjMapr 𝔅 c"
  shows " (umap_fo 𝔉 c r u dArrVal)  Hom 𝔅 (𝔉ObjMapd) c"
  by 
    (
      rule is_functor.umap_of_ArrVal_vrange[
        OF is_functor_op, unfolded cat_op_simps, OF assms, folded umap_fo_def
        ]
    )


subsubsection‹Universal map is an arrow in the category Set›

lemma (in is_functor) cf_arr_Set_umap_of: 
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and r: "r  𝔄Obj" 
    and d: "d  𝔄Obj"
    and u: "u : c 𝔅 𝔉ObjMapr"
  shows "arr_Set α (umap_of 𝔉 c r u d)"
proof(intro arr_SetI)
  interpret HomDom: category α 𝔄 by (rule assms(1))
  interpret HomCod: category α 𝔅 by (rule assms(2))
  note umap_of_components = umap_of_components[OF u]
  from u d have c: "c  𝔅Obj" and 𝔉d: "(𝔉ObjMapd)  𝔅Obj" 
    by (auto intro: cat_cs_intros)
  show "vfsequence (umap_of 𝔉 c r u d)" unfolding umap_of_def by simp
  show "vcard (umap_of 𝔉 c r u d) = 3"
    unfolding umap_of_def by (simp add: nat_omega_simps)
  from umap_of_ArrVal_vrange[OF u] show 
    " (umap_of 𝔉 c r u dArrVal)  umap_of 𝔉 c r u dArrCod"
    unfolding umap_of_components by simp
  from r d show "umap_of 𝔉 c r u dArrDom  Vset α"
    unfolding umap_of_components by (intro HomDom.cat_Hom_in_Vset)
  from c 𝔉d show "umap_of 𝔉 c r u dArrCod  Vset α"
    unfolding umap_of_components by (intro HomCod.cat_Hom_in_Vset)
qed (auto simp: umap_of_components[OF u])

lemma (in is_functor) cf_arr_Set_umap_fo: 
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and r: "r  𝔄Obj" 
    and d: "d  𝔄Obj"
    and u: "u : 𝔉ObjMapr 𝔅 c"
  shows "arr_Set α (umap_fo 𝔉 c r u d)"
proof-
  from assms(1) have 𝔄: "category α (op_cat 𝔄)" 
    by (auto intro: cat_cs_intros)
  from assms(2) have 𝔅: "category α (op_cat 𝔅)" 
    by (auto intro: cat_cs_intros)
  show ?thesis
    by 
      (
        rule 
          is_functor.cf_arr_Set_umap_of[
            OF is_functor_op, unfolded cat_op_simps, OF 𝔄 𝔅 r d u
            ]
      )
qed

lemma (in is_functor) cf_umap_of_is_arr:
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and "r  𝔄Obj" 
    and "d  𝔄Obj"
    and "u : c 𝔅 𝔉ObjMapr"
  shows "umap_of 𝔉 c r u d : Hom 𝔄 r d cat_Set α Hom 𝔅 c (𝔉ObjMapd)"
proof(intro cat_Set_is_arrI)
  show "arr_Set α (umap_of 𝔉 c r u d)" 
    by (rule cf_arr_Set_umap_of[OF assms])
qed (simp_all add: umap_of_components[OF assms(5)])

lemma (in is_functor) cf_umap_of_is_arr':
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and "r  𝔄Obj" 
    and "d  𝔄Obj"
    and "u : c 𝔅 𝔉ObjMapr"
    and "A = Hom 𝔄 r d"
    and "B = Hom 𝔅 c (𝔉ObjMapd)"
    and " = cat_Set α"
  shows "umap_of 𝔉 c r u d : A  B"
  using assms(1-5) unfolding assms(6-8) by (rule cf_umap_of_is_arr)

lemmas [cat_cs_intros] = is_functor.cf_umap_of_is_arr'

lemma (in is_functor) cf_umap_fo_is_arr:
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and "r  𝔄Obj" 
    and "d  𝔄Obj"
    and "u : 𝔉ObjMapr 𝔅 c"
  shows "umap_fo 𝔉 c r u d : Hom 𝔄 d r cat_Set α Hom 𝔅 (𝔉ObjMapd) c"
proof(intro cat_Set_is_arrI)
  show "arr_Set α (umap_fo 𝔉 c r u d)" 
    by (rule cf_arr_Set_umap_fo[OF assms])
qed (simp_all add: umap_fo_components[OF assms(5)])

lemma (in is_functor) cf_umap_fo_is_arr':
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and "r  𝔄Obj" 
    and "d  𝔄Obj"
    and "u : 𝔉ObjMapr 𝔅 c"
    and "A = Hom 𝔄 d r"
    and "B = Hom 𝔅 (𝔉ObjMapd) c"
    and " = cat_Set α"
  shows "umap_fo 𝔉 c r u d : A  B"
  using assms(1-5) unfolding assms(6-8) by (rule cf_umap_fo_is_arr)

lemmas [cat_cs_intros] = is_functor.cf_umap_fo_is_arr'



subsection‹Universal arrow: definition and elementary properties›


text‹See Chapter III-1 in \cite{mac_lane_categories_2010}.›

definition universal_arrow_of :: "V  V  V  V  bool"
  where "universal_arrow_of 𝔉 c r u 
    (
      r  𝔉HomDomObj 
      u : c 𝔉HomCod 𝔉ObjMapr 
      (
        r' u'.
          r'  𝔉HomDomObj 
          u' : c 𝔉HomCod 𝔉ObjMapr' 
          (∃!f'. f' : r 𝔉HomDom r'  u' = umap_of 𝔉 c r u r'ArrValf')
      )
    )"

definition universal_arrow_fo :: "V  V  V  V  bool"
  where "universal_arrow_fo 𝔉 c r u  universal_arrow_of (op_cf 𝔉) c r u"


text‹Rules.›

mk_ide (in is_functor) rf 
  universal_arrow_of_def[where 𝔉=𝔉, unfolded cf_HomDom cf_HomCod]
  |intro universal_arrow_ofI|
  |dest universal_arrow_ofD[dest]|
  |elim universal_arrow_ofE[elim]|

lemma (in is_functor) universal_arrow_foI:
  assumes "r  𝔄Obj" 
    and "u : 𝔉ObjMapr 𝔅 c" 
    and "r' u'.  r'  𝔄Obj; u' : 𝔉ObjMapr' 𝔅 c   
      ∃!f'. f' : r' 𝔄 r  u' = umap_fo 𝔉 c r u r'ArrValf'"
  shows "universal_arrow_fo 𝔉 c r u"
  by 
    (
      simp add: 
        is_functor.universal_arrow_ofI
          [
            OF is_functor_op, 
            folded universal_arrow_fo_def, 
            unfolded cat_op_simps, 
            OF assms
          ]
    )

lemma (in is_functor) universal_arrow_foD[dest]:
  assumes "universal_arrow_fo 𝔉 c r u"
  shows "r  𝔄Obj" 
    and "u : 𝔉ObjMapr 𝔅 c" 
    and "r' u'.  r'  𝔄Obj; u' : 𝔉ObjMapr' 𝔅 c   
      ∃!f'. f' : r' 𝔄 r  u' = umap_fo 𝔉 c r u r'ArrValf'"
  by
    (
      auto simp: 
        is_functor.universal_arrow_ofD
          [
            OF is_functor_op, 
            folded universal_arrow_fo_def, 
            unfolded cat_op_simps,
            OF assms
          ]
    )

lemma (in is_functor) universal_arrow_foE[elim]:
  assumes "universal_arrow_fo 𝔉 c r u"
  obtains "r  𝔄Obj" 
    and "u : 𝔉ObjMapr 𝔅 c" 
    and "r' u'.  r'  𝔄Obj; u' : 𝔉ObjMapr' 𝔅 c   
      ∃!f'. f' : r' 𝔄 r  u' = umap_fo 𝔉 c r u r'ArrValf'"
  using assms by (auto simp: universal_arrow_foD)


text‹Elementary properties.›

lemma (in is_functor) op_cf_universal_arrow_of[cat_op_simps]: 
  "universal_arrow_of (op_cf 𝔉) c r u  universal_arrow_fo 𝔉 c r u"
  unfolding universal_arrow_fo_def ..

lemma (in is_functor) op_cf_universal_arrow_fo[cat_op_simps]: 
  "universal_arrow_fo (op_cf 𝔉) c r u  universal_arrow_of 𝔉 c r u"
  unfolding universal_arrow_fo_def cat_op_simps ..

lemmas (in is_functor) [cat_op_simps] = 
  is_functor.op_cf_universal_arrow_of
  is_functor.op_cf_universal_arrow_fo



subsection‹Uniqueness›


text‹
The following properties are related to the uniqueness of the 
universal arrow. These properties can be inferred from the content of
Chapter III-1 in \cite{mac_lane_categories_2010}.
›

lemma (in is_functor) cf_universal_arrow_of_ex_is_arr_isomorphism:
  ―‹The proof is based on the ideas expressed in the proof of Theorem 5.2 
  in Chapter Introduction in \cite{hungerford_algebra_2003}.›
  assumes "universal_arrow_of 𝔉 c r u" and "universal_arrow_of 𝔉 c r' u'"
  obtains f where "f : r iso𝔄 r'" and "u' = umap_of 𝔉 c r u r'ArrValf"
proof-

  note ua1 = universal_arrow_ofD[OF assms(1)]
  note ua2 = universal_arrow_ofD[OF assms(2)]

  from ua1(1) have 𝔄r: "𝔄CIdr : r 𝔄 r" by (auto intro: cat_cs_intros)
  from ua1(1) have "𝔉ArrMap𝔄CIdr = 𝔅CId𝔉ObjMapr"
    by (auto intro: cat_cs_intros)
  with ua1(1,2) have u_def: "u = umap_of 𝔉 c r u rArrVal𝔄CIdr"
    unfolding umap_of_ArrVal_app[OF 𝔄r ua1(2)] by (auto simp: cat_cs_simps)

  from ua2(1) have 𝔄r': "𝔄CIdr' : r' 𝔄 r'" by (auto intro: cat_cs_intros)
  from ua2(1) have "𝔉ArrMap𝔄CIdr' = 𝔅CId𝔉ObjMapr'" 
    by (auto intro: cat_cs_intros)
  with ua2(1,2) have u'_def: "u' = umap_of 𝔉 c r' u' r'ArrVal𝔄CIdr'"
    unfolding umap_of_ArrVal_app[OF 𝔄r' ua2(2)] by (auto simp: cat_cs_simps)

  from 𝔄r u_def universal_arrow_ofD(3)[OF assms(1) ua1(1,2)] have eq_CId_rI: 
    " f' : r 𝔄 r; u = umap_of 𝔉 c r u rArrValf'   f' = 𝔄CIdr" 
    for f'
    by blast
  from 𝔄r' u'_def universal_arrow_ofD(3)[OF assms(2) ua2(1,2)] have eq_CId_r'I: 
    " f' : r' 𝔄 r'; u' = umap_of 𝔉 c r' u' r'ArrValf'  
      f' = 𝔄CIdr'" 
    for f'
    by blast

  from ua1(3)[OF ua2(1,2)] obtain f 
    where f: "f : r 𝔄 r'" 
      and u'_def: "u' = umap_of 𝔉 c r u r'ArrValf"
      and "g : r 𝔄 r'  u' = umap_of 𝔉 c r u r'ArrValg  f = g" 
    for g
    by metis
  from ua2(3)[OF ua1(1,2)] obtain f' 
    where f': "f' : r' 𝔄 r" 
      and u_def: "u = umap_of 𝔉 c r' u' rArrValf'"
      and "g : r' 𝔄 r  u = umap_of 𝔉 c r' u' rArrValg  f' = g" 
    for g
    by metis

  have "f : r iso𝔄 r'"
  proof(intro is_arr_isomorphismI is_inverseI)
    show f: "f : r 𝔄 r'" by (rule f)
    show f': "f' : r' 𝔄 r" by (rule f')
    show "f : r 𝔄 r'" by (rule f)
    from f' have 𝔉f': "𝔉ArrMapf' : 𝔉ObjMapr' 𝔅 𝔉ObjMapr" 
      by (auto intro: cat_cs_intros)
    from f have 𝔉f: "𝔉ArrMapf : 𝔉ObjMapr 𝔅 𝔉ObjMapr'" 
      by (auto intro: cat_cs_intros)
    note u'_def' = u'_def[symmetric, unfolded umap_of_ArrVal_app[OF f ua1(2)]] 
      and u_def' = u_def[symmetric, unfolded umap_of_ArrVal_app[OF f' ua2(2)]]
    show "f' A𝔄 f = 𝔄CIdr"
    proof(rule eq_CId_rI)
      from f f' show f'f: "f' A𝔄 f : r 𝔄 r" 
        by (auto intro: cat_cs_intros)
      from ua1(2) 𝔉f' 𝔉f show "u = umap_of 𝔉 c r u rArrValf' A𝔄 f"
        unfolding umap_of_ArrVal_app[OF f'f ua1(2)] cf_ArrMap_Comp[OF f' f]
        by (simp add: HomCod.cat_Comp_assoc u'_def' u_def')
    qed
    show "f A𝔄 f' = 𝔄CIdr'"
    proof(rule eq_CId_r'I)
      from f f' show ff': "f A𝔄 f' : r' 𝔄 r'" 
        by (auto intro: cat_cs_intros)
      from ua2(2) 𝔉f' 𝔉f show "u' = umap_of 𝔉 c r' u' r'ArrValf A𝔄 f'"
        unfolding umap_of_ArrVal_app[OF ff' ua2(2)] cf_ArrMap_Comp[OF f f']
        by (simp add: HomCod.cat_Comp_assoc u'_def' u_def')
    qed
  qed
  
  with u'_def that show ?thesis by auto

qed

lemma (in is_functor) cf_universal_arrow_fo_ex_is_arr_isomorphism:
  assumes "universal_arrow_fo 𝔉 c r u"
    and "universal_arrow_fo 𝔉 c r' u'"
  obtains f where "f : r' iso𝔄 r" and "u' = umap_fo 𝔉 c r u r'ArrValf"
  by 
    (
      elim 
        is_functor.cf_universal_arrow_of_ex_is_arr_isomorphism[
          OF is_functor_op, unfolded cat_op_simps, OF assms
          ]
    )

lemma (in is_functor) cf_universal_arrow_of_unique:
  assumes "universal_arrow_of 𝔉 c r u"
    and "universal_arrow_of 𝔉 c r' u'"
  shows "∃!f'. f' : r 𝔄 r'  u' = umap_of 𝔉 c r u r'ArrValf'"
proof-
  note ua1 = universal_arrow_ofD[OF assms(1)]
  note ua2 = universal_arrow_ofD[OF assms(2)]
  from ua1(3)[OF ua2(1,2)] show ?thesis .
qed

lemma (in is_functor) cf_universal_arrow_fo_unique:
  assumes "universal_arrow_fo 𝔉 c r u"
    and "universal_arrow_fo 𝔉 c r' u'"
  shows "∃!f'. f' : r' 𝔄 r  u' = umap_fo 𝔉 c r u r'ArrValf'"
proof-
  note ua1 = universal_arrow_foD[OF assms(1)]
  note ua2 = universal_arrow_foD[OF assms(2)]
  from ua1(3)[OF ua2(1,2)] show ?thesis .
qed

lemma (in is_functor) cf_universal_arrow_of_is_arr_isomorphism:
  assumes "universal_arrow_of 𝔉 c r u"
    and "universal_arrow_of 𝔉 c r' u'"
    and "f : r 𝔄 r'" 
    and "u' = umap_of 𝔉 c r u r'ArrValf"
  shows "f : r iso𝔄 r'"
proof-
  from assms(3,4) cf_universal_arrow_of_unique[OF assms(1,2)] have eq: 
    "g : r 𝔄 r'  u' = umap_of 𝔉 c r u r'ArrValg  f = g" for g
    by blast
  from assms(1,2) obtain f' 
    where iso_f': "f' : r iso𝔄 r'" 
      and u'_def: "u' = umap_of 𝔉 c r u r'ArrValf'"
    by (auto elim: cf_universal_arrow_of_ex_is_arr_isomorphism)
  then have f': "f' : r 𝔄 r'" by auto
  from iso_f' show ?thesis unfolding eq[OF f' u'_def, symmetric].
qed

lemma (in is_functor) cf_universal_arrow_fo_is_arr_isomorphism:
  assumes "universal_arrow_fo 𝔉 c r u"
    and "universal_arrow_fo 𝔉 c r' u'"
    and "f : r' 𝔄 r" 
    and "u' = umap_fo 𝔉 c r u r'ArrValf"
  shows "f : r' iso𝔄 r"
  by 
    (
      rule 
        is_functor.cf_universal_arrow_of_is_arr_isomorphism[
          OF is_functor_op, unfolded cat_op_simps, OF assms
          ]
    )



subsection‹Universal natural transformation›


subsubsection‹Definition and elementary properties›


text‹
The concept of the universal natural transformation is introduced for the 
statement of the elements of a variant of Proposition 1 in Chapter III-2
in \cite{mac_lane_categories_2010}.
›

definition ntcf_ua_of :: "V  V  V  V  V  V"
  where "ntcf_ua_of α 𝔉 c r u =
    [
      (λd𝔉HomDomObj. umap_of 𝔉 c r u d),
      HomO.Cα𝔉HomDom(r,-),
      HomO.Cα𝔉HomCod(c,-) CF 𝔉,
      𝔉HomDom,
      cat_Set α
    ]"

definition ntcf_ua_fo :: "V  V  V  V  V  V"
  where "ntcf_ua_fo α 𝔉 c r u = ntcf_ua_of α (op_cf 𝔉) c r u"


text‹Components.›

lemma ntcf_ua_of_components:
  shows "ntcf_ua_of α 𝔉 c r uNTMap = (λd𝔉HomDomObj. umap_of 𝔉 c r u d)"
    and "ntcf_ua_of α 𝔉 c r uNTDom = HomO.Cα𝔉HomDom(r,-)"
    and "ntcf_ua_of α 𝔉 c r uNTCod = HomO.Cα𝔉HomCod(c,-) CF 𝔉"
    and "ntcf_ua_of α 𝔉 c r uNTDGDom = 𝔉HomDom"
    and "ntcf_ua_of α 𝔉 c r uNTDGCod = cat_Set α"
  unfolding ntcf_ua_of_def nt_field_simps by (simp_all add: nat_omega_simps) 

lemma ntcf_ua_fo_components:
  shows "ntcf_ua_fo α 𝔉 c r uNTMap = (λd𝔉HomDomObj. umap_fo 𝔉 c r u d)"
    and "ntcf_ua_fo α 𝔉 c r uNTDom = HomO.Cαop_cat (𝔉HomDom)(r,-)"
    and "ntcf_ua_fo α 𝔉 c r uNTCod =
      HomO.Cαop_cat (𝔉HomCod)(c,-) CF op_cf 𝔉"
    and "ntcf_ua_fo α 𝔉 c r uNTDGDom = op_cat (𝔉HomDom)"
    and "ntcf_ua_fo α 𝔉 c r uNTDGCod = cat_Set α"
  unfolding ntcf_ua_fo_def ntcf_ua_of_components umap_fo_def cat_op_simps 
  by simp_all

context is_functor
begin

lemmas ntcf_ua_of_components' = 
  ntcf_ua_of_components[where α=α and 𝔉=𝔉, unfolded cat_cs_simps]

lemmas [cat_cs_simps] = ntcf_ua_of_components'(2-5)

lemma ntcf_ua_fo_components':
  assumes "c  𝔅Obj" and "r  𝔄Obj" 
  shows "ntcf_ua_fo α 𝔉 c r uNTMap = (λd𝔄Obj. umap_fo 𝔉 c r u d)"
    and [cat_cs_simps]: 
      "ntcf_ua_fo α 𝔉 c r uNTDom = HomO.Cα𝔄(-,r)"
    and [cat_cs_simps]: 
      "ntcf_ua_fo α 𝔉 c r uNTCod = HomO.Cα𝔅(-,c) CF op_cf 𝔉"
    and [cat_cs_simps]: "ntcf_ua_fo α 𝔉 c r uNTDGDom = op_cat 𝔄"
    and [cat_cs_simps]: "ntcf_ua_fo α 𝔉 c r uNTDGCod = cat_Set α"
  unfolding
    ntcf_ua_fo_components cat_cs_simps
    HomDom.cat_op_cat_cf_Hom_snd[OF assms(2)] 
    HomCod.cat_op_cat_cf_Hom_snd[OF assms(1)]
  by simp_all

end

lemmas [cat_cs_simps] = 
  is_functor.ntcf_ua_of_components'(2-5)
  is_functor.ntcf_ua_fo_components'(2-5)


subsubsection‹Natural transformation map›

mk_VLambda (in is_functor) 
  ntcf_ua_of_components(1)[where α=α and 𝔉=𝔉, unfolded cf_HomDom]
  |vsv ntcf_ua_of_NTMap_vsv|
  |vdomain ntcf_ua_of_NTMap_vdomain|
  |app ntcf_ua_of_NTMap_app|

context is_functor
begin

context
  fixes c r
  assumes r: "r  𝔄Obj" and c: "c  𝔅Obj" 
begin

mk_VLambda ntcf_ua_fo_components'(1)[OF c r]
  |vsv ntcf_ua_fo_NTMap_vsv|
  |vdomain ntcf_ua_fo_NTMap_vdomain|
  |app ntcf_ua_fo_NTMap_app|

end

end

lemmas [cat_cs_intros] = 
  is_functor.ntcf_ua_fo_NTMap_vsv
  is_functor.ntcf_ua_of_NTMap_vsv

lemmas [cat_cs_simps] = 
  is_functor.ntcf_ua_fo_NTMap_vdomain
  is_functor.ntcf_ua_fo_NTMap_app
  is_functor.ntcf_ua_of_NTMap_vdomain
  is_functor.ntcf_ua_of_NTMap_app

lemma (in is_functor) ntcf_ua_of_NTMap_vrange:
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and "r  𝔄Obj" 
    and "u : c 𝔅 𝔉ObjMapr"
  shows " (ntcf_ua_of α 𝔉 c r uNTMap)  cat_Set αArr"
proof(rule vsv.vsv_vrange_vsubset, unfold ntcf_ua_of_NTMap_vdomain)
  show "vsv (ntcf_ua_of α 𝔉 c r uNTMap)" by (rule ntcf_ua_of_NTMap_vsv)
  fix d assume prems: "d  𝔄Obj"
  with category_cat_Set is_functor_axioms assms show 
    "ntcf_ua_of α 𝔉 c r uNTMapd  cat_Set αArr"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed


subsubsection‹Commutativity of the universal maps and hom›-functions›

lemma (in is_functor) cf_umap_of_cf_hom_commute: 
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "c  𝔅Obj"
    and "r  𝔄Obj"
    and "u : c 𝔅 𝔉ObjMapr"
    and "f : a 𝔄 b"
  shows 
    "umap_of 𝔉 c r u b Acat_Set α cf_hom 𝔄 [𝔄CIdr, f] =
      cf_hom 𝔅 [𝔅CIdc, 𝔉ArrMapf] Acat_Set α umap_of 𝔉 c r u a"
  (is ?uof_b Acat_Set α ?rf = ?cf Acat_Set α ?uof_a)
proof-

  from is_functor_axioms category_cat_Set assms(1,2,4-6) have b_rf: 
    "?uof_b Acat_Set α ?rf : Hom 𝔄 r a cat_Set α Hom 𝔅 c (𝔉ObjMapb)"
    by (cs_concl cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros)
  from is_functor_axioms category_cat_Set assms(1,2,4-6) have cf_a: 
    "?cf Acat_Set α ?uof_a : Hom 𝔄 r a cat_Set α Hom 𝔅 c (𝔉ObjMapb)"
    by (cs_concl cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros)

  show ?thesis
  proof(rule arr_Set_eqI[of α])
    from b_rf show arr_Set_b_rf: "arr_Set α (?uof_b Acat_Set α ?rf)"
      by (auto dest: cat_Set_is_arrD(1))
    from b_rf have dom_lhs: 
      "𝒟 ((?uof_b Acat_Set α ?rf)ArrVal) = Hom 𝔄 r a"
      by (cs_concl cs_simp: cat_cs_simps)+
    from cf_a show arr_Set_cf_a: "arr_Set α (?cf Acat_Set α ?uof_a)"
      by (auto dest: cat_Set_is_arrD(1))
    from cf_a have dom_rhs: 
      "𝒟 ((?cf Acat_Set α ?uof_a)ArrVal) = Hom 𝔄 r a"
      by (cs_concl cs_simp: cat_cs_simps)
    show "(?uof_b Acat_Set α ?rf)ArrVal = (?cf Acat_Set α ?uof_a)ArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
      fix q assume "q : r 𝔄 a"
      with is_functor_axioms category_cat_Set assms show 
        "(?uof_b Acat_Set α ?rf)ArrValq =
          (?cf Acat_Set α ?uof_a)ArrValq"
        by (*slow*)
          (
            cs_concl
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
         )
    qed (use arr_Set_b_rf arr_Set_cf_a in auto)
  
  qed (use b_rf cf_a in cs_concl cs_simp: cat_cs_simps)+

qed

lemma cf_umap_of_cf_hom_unit_commute:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
    and "g : c'  c" 
    and "f : d 𝔇 d'"
  shows 
    "umap_of 𝔊 c' (𝔉ObjMapc') (ηNTMapc') d' Acat_Set α
      cf_hom 𝔇 [𝔉ArrMapg, f] =
        cf_hom  [g, 𝔊ArrMapf] Acat_Set α
          umap_of 𝔊 c (𝔉ObjMapc) (ηNTMapc) d"
  (is ?uof_c'd' Acat_Set α ?𝔉gf = ?g𝔊f Acat_Set α ?uof_cd)
proof-

  interpret η: is_ntcf α   ‹cf_id  𝔊 CF 𝔉 η by (rule assms(5))

  from assms have c'd'_𝔉gf: "?uof_c'd' Acat_Set α ?𝔉gf :
    Hom 𝔇 (𝔉ObjMapc) d cat_Set α Hom  c' (𝔊ObjMapd')"
    by
      (
        cs_concl
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
      )
  then have dom_lhs:
    "𝒟 ((?uof_c'd' Acat_Set α ?𝔉gf)ArrVal) = Hom 𝔇 (𝔉ObjMapc) d"
    by (cs_concl cs_simp: cat_cs_simps)
  from assms have g𝔊f_cd: "?g𝔊f Acat_Set α ?uof_cd :
    Hom 𝔇 (𝔉ObjMapc) d cat_Set α Hom  c' (𝔊ObjMapd')"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
      )
  then have dom_rhs: 
    "𝒟 ((?g𝔊f Acat_Set α ?uof_cd)ArrVal) = Hom 𝔇 (𝔉ObjMapc) d"
    by (cs_concl cs_simp: cat_cs_simps)

  show ?thesis
  proof(rule arr_Set_eqI[of α])
    from c'd'_𝔉gf show arr_Set_c'd'_𝔉gf: 
      "arr_Set α (?uof_c'd' Acat_Set α ?𝔉gf)"
      by (auto dest: cat_Set_is_arrD(1))
    from g𝔊f_cd show arr_Set_g𝔊f_cd:
      "arr_Set α (?g𝔊f Acat_Set α ?uof_cd)"
      by (auto dest: cat_Set_is_arrD(1))
    show 
      "(?uof_c'd' Acat_Set α ?𝔉gf)ArrVal =
        (?g𝔊f Acat_Set α ?uof_cd)ArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
      fix h assume prems: "h : 𝔉ObjMapc 𝔇 d"
      from η.ntcf_Comp_commute[OF assms(6)] assms have [cat_cs_simps]:
        "ηNTMapc A g = 𝔊ArrMap𝔉ArrMapg A ηNTMapc'"
        by (cs_prems cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
      from assms prems show 
        "(?uof_c'd' Acat_Set α ?𝔉gf)ArrValh =
          (?g𝔊f Acat_Set α ?uof_cd)ArrValh"
        by 
          (
            cs_concl
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros  
              cs_simp: cat_cs_simps
          )
    qed (use arr_Set_c'd'_𝔉gf arr_Set_g𝔊f_cd in auto)
 
  qed (use c'd'_𝔉gf g𝔊f_cd in cs_concl cs_simp: cat_cs_simps)+

qed


subsubsection‹Universal natural transformation is a natural transformation›

lemma (in is_functor) cf_ntcf_ua_of_is_ntcf:
  assumes "r  𝔄Obj"
    and "u : c 𝔅 𝔉ObjMapr"
  shows "ntcf_ua_of α 𝔉 c r u :
    HomO.Cα𝔄(r,-) CF HomO.Cα𝔅(c,-) CF 𝔉 : 𝔄 ↦↦Cα cat_Set α"
proof(intro is_ntcfI')
  let ?ua = ‹ntcf_ua_of α 𝔉 c r u
  show "vfsequence (ntcf_ua_of α 𝔉 c r u)" unfolding ntcf_ua_of_def by simp
  show "vcard ?ua = 5" unfolding ntcf_ua_of_def by (simp add: nat_omega_simps)
  from assms(1) show "HomO.Cα𝔄(r,-) : 𝔄 ↦↦Cα cat_Set α"
    by (cs_concl cs_intro: cat_cs_intros)
  from is_functor_axioms assms(2) show 
    "HomO.Cα𝔅(c,-) CF 𝔉 : 𝔄 ↦↦Cα cat_Set α"
    by (cs_concl cs_intro: cat_cs_intros)
  from is_functor_axioms assms show "𝒟 (?uaNTMap) = 𝔄Obj"
    by (cs_concl cs_simp: cat_cs_simps)
  show "?uaNTMapa :
    HomO.Cα𝔄(r,-)ObjMapa cat_Set α (HomO.Cα𝔅(c,-) CF 𝔉)ObjMapa"
    if "a  𝔄Obj" for a
    using is_functor_axioms assms that 
    by (cs_concl cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
  show "?uaNTMapb Acat_Set α HomO.Cα𝔄(r,-)ArrMapf =
    (HomO.Cα𝔅(c,-) CF 𝔉)ArrMapf Acat_Set α ?uaNTMapa"
    if "f : a 𝔄 b" for a b f
    using is_functor_axioms assms that 
    by 
      ( 
        cs_concl 
          cs_simp: cf_umap_of_cf_hom_commute cat_cs_simps cat_op_simps 
          cs_intro: cat_cs_intros cat_op_intros
      )
qed (auto simp: ntcf_ua_of_components cat_cs_simps)

lemma (in is_functor) cf_ntcf_ua_fo_is_ntcf:
  assumes "r  𝔄Obj" and "u : 𝔉ObjMapr 𝔅 c"
  shows "ntcf_ua_fo α 𝔉 c r u :
    HomO.Cα𝔄(-,r) CF HomO.Cα𝔅(-,c) CF op_cf 𝔉 :
    op_cat 𝔄 ↦↦Cα cat_Set α"
proof-
  from assms(2) have c: "c  𝔅Obj" by auto
  show ?thesis
    by 
      (
        rule is_functor.cf_ntcf_ua_of_is_ntcf
          [
            OF is_functor_op, 
            unfolded cat_op_simps, 
            OF assms(1,2),
            unfolded 
              HomDom.cat_op_cat_cf_Hom_snd[OF assms(1)] 
              HomCod.cat_op_cat_cf_Hom_snd[OF c]
              ntcf_ua_fo_def[symmetric]
          ]
      )
qed


subsubsection‹Universal natural transformation and universal arrow›


text‹
The lemmas in this subsection correspond to 
variants of elements of Proposition 1 in Chapter III-2 in 
\cite{mac_lane_categories_2010}.
›

lemma (in is_functor) cf_ntcf_ua_of_is_iso_ntcf:
  assumes "universal_arrow_of 𝔉 c r u"
  shows "ntcf_ua_of α 𝔉 c r u :
    HomO.Cα𝔄(r,-) CF.iso HomO.Cα𝔅(c,-) CF 𝔉 : 𝔄 ↦↦Cα cat_Set α"
proof-

  have r: "r  𝔄Obj"
    and u: "u : c 𝔅 𝔉ObjMapr"
    and bij: "r' u'.
      
        r'  𝔄Obj; 
        u' : c 𝔅 𝔉ObjMapr'
        ∃!f'. f' : r 𝔄 r'  u' = umap_of 𝔉 c r u r'ArrValf'"
    by (auto intro!: universal_arrow_ofD[OF assms(1)])

  show ?thesis
  proof(intro is_iso_ntcfI)
    show "ntcf_ua_of α 𝔉 c r u :
      HomO.Cα𝔄(r,-) CF HomO.Cα𝔅(c,-) CF 𝔉 : 𝔄 ↦↦Cα cat_Set α"
      by (rule cf_ntcf_ua_of_is_ntcf[OF r u])
    fix a assume prems: "a  𝔄Obj"
    from is_functor_axioms prems r u have [simp]:
      "umap_of 𝔉 c r u a : Hom 𝔄 r a cat_Set α Hom 𝔅 c (𝔉ObjMapa)"
      by (cs_concl cs_intro: cat_cs_intros)
    then have dom: "𝒟 (umap_of 𝔉 c r u aArrVal) = Hom 𝔄 r a"
      by (cs_concl cs_simp: cat_cs_simps)
    have "umap_of 𝔉 c r u a : Hom 𝔄 r a isocat_Set α Hom 𝔅 c (𝔉ObjMapa)"
    proof(intro cat_Set_is_arr_isomorphismI, unfold dom)
 
      show umof_a: "v11 (umap_of 𝔉 c r u aArrVal)"
      proof(intro vsv.vsv_valeq_v11I, unfold dom in_Hom_iff)
        fix g f assume prems': 
          "g : r 𝔄 a"
          "f : r 𝔄 a" 
          "umap_of 𝔉 c r u aArrValg = umap_of 𝔉 c r u aArrValf"
        from is_functor_axioms r u prems'(1) have 𝔉g:
          "𝔉ArrMapg A𝔅 u : c 𝔅 𝔉ObjMapa"
          by (cs_concl cs_intro: cat_cs_intros)
        from bij[OF prems 𝔉g] have unique:
          "
            f' : r 𝔄 a;
            𝔉ArrMapg A𝔅 u = umap_of 𝔉 c r u aArrValf' 
             g = f'"
          for f' by (metis prems'(1) u umap_of_ArrVal_app)
        from is_functor_axioms prems'(1,2) u have 𝔉g_u:
          "𝔉ArrMapg A𝔅 u = umap_of 𝔉 c r u aArrValf"
          by (cs_concl cs_simp: prems'(3)[symmetric] cat_cs_simps)
        show "g = f" by (rule unique[OF prems'(2) 𝔉g_u])
      qed (auto simp: cat_cs_simps cat_cs_intros)

      interpret umof_a: v11 ‹umap_of 𝔉 c r u aArrVal by (rule umof_a)

      show " (umap_of 𝔉 c r u aArrVal) = Hom 𝔅 c (𝔉ObjMapa)"
      proof(intro vsubset_antisym)
        from u show " (umap_of 𝔉 c r u aArrVal)  Hom 𝔅 c (𝔉ObjMapa)"
          by (rule umap_of_ArrVal_vrange)
        show "Hom 𝔅 c (𝔉ObjMapa)   (umap_of 𝔉 c r u aArrVal)"
        proof(rule vsubsetI, unfold in_Hom_iff )
          fix f assume prems': "f : c 𝔅 𝔉ObjMapa"
          from bij[OF prems prems'] obtain f' 
            where f': "f' : r 𝔄 a" 
              and f_def: "f = umap_of 𝔉 c r u aArrValf'"
            by auto
          from is_functor_axioms prems prems' u f' have 
            "f'  𝒟 (umap_of 𝔉 c r u aArrVal)"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          from this show "f   (umap_of 𝔉 c r u aArrVal)"
            unfolding f_def by (rule umof_a.vsv_vimageI2)
        qed

      qed

    qed simp_all

    from is_functor_axioms prems r u this show 
      "ntcf_ua_of α 𝔉 c r uNTMapa :
        HomO.Cα𝔄(r,-)ObjMapa isocat_Set α
        (HomO.Cα𝔅(c,-) CF 𝔉)ObjMapa"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_op_simps 
            cs_intro: cat_cs_intros cat_op_intros
        )
  qed

qed

lemmas [cat_cs_intros] = is_functor.cf_ntcf_ua_of_is_iso_ntcf

lemma (in is_functor) cf_ntcf_ua_fo_is_iso_ntcf:
  assumes "universal_arrow_fo 𝔉 c r u"
  shows "ntcf_ua_fo α 𝔉 c r u :
    HomO.Cα𝔄(-,r) CF.iso HomO.Cα𝔅(-,c) CF op_cf 𝔉 :
    op_cat 𝔄 ↦↦Cα cat_Set α"
proof-
  from universal_arrow_foD[OF assms] have r: "r  𝔄Obj" and c: "c  𝔅Obj"
    by auto
  show ?thesis
    by 
      (
        rule is_functor.cf_ntcf_ua_of_is_iso_ntcf
          [
            OF is_functor_op, 
            unfolded cat_op_simps, 
            OF assms,
            unfolded 
              HomDom.cat_op_cat_cf_Hom_snd[OF r] 
              HomCod.cat_op_cat_cf_Hom_snd[OF c]
              ntcf_ua_fo_def[symmetric]
          ]
      ) 
qed

lemmas [cat_cs_intros] = is_functor.cf_ntcf_ua_fo_is_iso_ntcf

lemma (in is_functor) cf_ua_of_if_ntcf_ua_of_is_iso_ntcf:
  assumes "r  𝔄Obj"
    and "u : c 𝔅 𝔉ObjMapr"
    and "ntcf_ua_of α 𝔉 c r u :
      HomO.Cα𝔄(r,-) CF.iso HomO.Cα𝔅(c,-) CF 𝔉 : 𝔄 ↦↦Cα cat_Set α"
  shows "universal_arrow_of 𝔉 c r u"
proof(rule universal_arrow_ofI)
  interpret ua_of_u: is_iso_ntcf 
    α 
    𝔄 
    ‹cat_Set α
    HomO.Cα𝔄(r,-) 
    HomO.Cα𝔅(c,-) CF 𝔉 
    ‹ntcf_ua_of α 𝔉 c r u
    by (rule assms(3))
  fix r' u' assume prems: "r'  𝔄Obj" "u' : c 𝔅 𝔉ObjMapr'"  
  have "ntcf_ua_of α 𝔉 c r uNTMapr' :
    HomO.Cα𝔄(r,-)ObjMapr' isocat_Set α
    (HomO.Cα𝔅(c,-) CF 𝔉)ObjMapr'"
    by (rule is_iso_ntcf.iso_ntcf_is_arr_isomorphism[OF assms(3) prems(1)])
  from this is_functor_axioms assms(1-2) prems have uof_r':
    "umap_of 𝔉 c r u r' : Hom 𝔄 r r' isocat_Set α Hom 𝔅 c (𝔉ObjMapr')"
    by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros)
  note uof_r' = cat_Set_is_arr_isomorphismD[OF uof_r']  
  interpret uof_r': v11 ‹umap_of 𝔉 c r u r'ArrVal by (rule uof_r'(2))  
  from 
    uof_r'.v11_vrange_ex1_eq[
      THEN iffD1, unfolded uof_r'(3,4) in_Hom_iff, OF prems(2)
      ] 
  show "∃!f'. f' : r 𝔄 r'  u' = umap_of 𝔉 c r u r'ArrValf'"
    by metis
qed (intro assms)+

lemma (in is_functor) cf_ua_fo_if_ntcf_ua_fo_is_iso_ntcf:
  assumes "r  𝔄Obj"
    and "u : 𝔉ObjMapr 𝔅 c"
    and "ntcf_ua_fo α 𝔉 c r u :
      HomO.Cα𝔄(-,r) CF.iso HomO.Cα𝔅(-,c) CF op_cf 𝔉 :
      op_cat 𝔄 ↦↦Cα cat_Set α"
  shows "universal_arrow_fo 𝔉 c r u"
proof-
  from assms(2) have c: "c  𝔅Obj" by auto
  show ?thesis
    by 
      (
        rule is_functor.cf_ua_of_if_ntcf_ua_of_is_iso_ntcf
          [
            OF is_functor_op, 
            unfolded cat_op_simps,
            OF assms(1,2),
            unfolded 
              HomDom.cat_op_cat_cf_Hom_snd[OF assms(1)] 
              HomCod.cat_op_cat_cf_Hom_snd[OF c]
              ntcf_ua_fo_def[symmetric],
            OF assms(3)
          ]
      )
qed

lemma (in is_functor) cf_universal_arrow_of_if_is_iso_ntcf:
  assumes "r  𝔄Obj"
    and "c  𝔅Obj"
    and "φ :
      HomO.Cα𝔄(r,-) CF.iso HomO.Cα𝔅(c,-) CF 𝔉 :
      𝔄 ↦↦Cα cat_Set α"
  shows "universal_arrow_of 𝔉 c r (φNTMaprArrVal𝔄CIdr)"
    (is ‹universal_arrow_of 𝔉 c r ?u)
proof-

  interpret φ: is_iso_ntcf 
    α 𝔄 ‹cat_Set α HomO.Cα𝔄(r,-) HomO.Cα𝔅(c,-) CF 𝔉 φ
    by (rule assms(3))

  show ?thesis
  proof(intro universal_arrow_ofI assms)
 
    from assms(1,2) show u: "?u : c 𝔅 𝔉ObjMapr"
      by (cs_concl cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
    fix r' u' assume prems: "r'  𝔄Obj" "u' : c 𝔅 𝔉ObjMapr'"
    have φr'_ArrVal_app[symmetric, cat_cs_simps]:
      "φNTMapr'ArrValf' =
        𝔉ArrMapf' A𝔅 φNTMaprArrVal𝔄CIdr"
      if "f' : r 𝔄 r'" for f'
    proof-
      have "φNTMapr' Acat_Set α HomO.Cα𝔄(r,-)ArrMapf' =
        (HomO.Cα𝔅(c,-) CF 𝔉)ArrMapf' Acat_Set α φNTMapr"
        using that by (intro φ.ntcf_Comp_commute)
      then have 
        "φNTMapr' Acat_Set α cf_hom 𝔄 [𝔄CIdr, f'] =
          cf_hom 𝔅 [𝔅CIdc, 𝔉ArrMapf'] Acat_Set α φNTMapr" 
        using assms(1,2) that prems
        by (cs_prems cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
      then have
        "(φNTMapr' Acat_Set α
        cf_hom 𝔄 [𝔄CIdr, f'])ArrVal𝔄CIdr =
          (cf_hom 𝔅 [𝔅CIdc, 𝔉ArrMapf'] Acat_Set α
          φNTMapr)ArrVal𝔄CIdr"
         by simp
      from this assms(1,2) u that show ?thesis
        by
          (
            cs_prems
              cs_simp: cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
    qed 
    
    show "∃!f'. f' : r 𝔄 r'  u' = umap_of 𝔉 c r ?u r'ArrValf'"
    proof(intro ex1I conjI; (elim conjE)?)
      from assms prems show 
        "(φNTMapr')¯Ccat_Set αArrValu' : r 𝔄 r'"
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_arrow_cs_intros
          )
      with assms(1,2) prems show "u' =
        umap_of 𝔉 c r ?u r'ArrVal(φNTMapr')¯Ccat_Set αArrValu'"
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_arrow_cs_intros cat_cs_intros cat_op_intros
          )
      fix f' assume prems': 
        "f' : r 𝔄 r'"
        "u' = umap_of 𝔉 c r (φNTMaprArrVal𝔄CIdr) r'ArrValf'"
      from prems'(2,1) assms(1,2) have u'_def: 
        "u' = 𝔉ArrMapf' A𝔅 φNTMaprArrVal𝔄CIdr"
        by
          (
            cs_prems
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros
          )
      from prems' show "f' = (φNTMapr')¯Ccat_Set αArrValu'"
        unfolding u'_def φr'_ArrVal_app[OF prems'(1)]
        by
          (
            cs_concl
              cs_simp: cat_cs_simps
              cs_intro: cat_arrow_cs_intros cat_cs_intros cat_op_intros
          )

    qed

  qed

qed

lemma (in is_functor) cf_universal_arrow_fo_if_is_iso_ntcf:
  assumes "r  𝔄Obj"
    and "c  𝔅Obj"
    and "φ :
      HomO.Cα𝔄(-,r) CF.iso HomO.Cα𝔅(-,c) CF op_cf 𝔉 :
      op_cat 𝔄 ↦↦Cα cat_Set α"
  shows "universal_arrow_fo 𝔉 c r (φNTMaprArrVal𝔄CIdr)"
  by
    (
      rule is_functor.cf_universal_arrow_of_if_is_iso_ntcf
        [
          OF is_functor_op,
          unfolded cat_op_simps,
          OF assms(1,2),
          unfolded 
            HomDom.cat_op_cat_cf_Hom_snd[OF assms(1)] 
            HomCod.cat_op_cat_cf_Hom_snd[OF assms(2)]
            ntcf_ua_fo_def[symmetric],
          OF assms(3)
        ]
  )

lemma (in is_functor) cf_universal_arrow_of_if_is_iso_ntcf_if_ge_Limit:
  assumes "𝒵 β"
    and "α  β"
    and "r  𝔄Obj"
    and "c  𝔅Obj"
    and "φ :
      HomO.Cβ𝔄(r,-) CF.iso HomO.Cβ𝔅(c,-) CF 𝔉 :
      𝔄 ↦↦Cβ cat_Set β"
  shows "universal_arrow_of 𝔉 c r (φNTMaprArrVal𝔄CIdr)"
    (is ‹universal_arrow_of 𝔉 c r ?u)
proof-

  interpret β: 𝒵 β by (rule assms(1))
  interpret cat_Set_αβ: subcategory β ‹cat_Set α ‹cat_Set β
    by (rule subcategory_cat_Set_cat_Set[OF assms(1,2)])
  interpret φ: is_iso_ntcf 
    β 𝔄 ‹cat_Set β HomO.Cβ𝔄(r,-) HomO.Cβ𝔅(c,-) CF 𝔉 φ
    by (rule assms(5))
  interpret β𝔄: category β 𝔄
    by (rule category.cat_category_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+
  interpret β𝔅: category β 𝔅
    by (rule category.cat_category_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+
  interpret β𝔉: is_functor β 𝔄 𝔅 𝔉
    by (rule cf_is_functor_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+

  show ?thesis
  proof(intro universal_arrow_ofI assms)
 
    from assms(3,4) show u: "?u : c 𝔅 𝔉ObjMapr"
      by (cs_concl cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
    fix r' u' assume prems: "r'  𝔄Obj" "u' : c 𝔅 𝔉ObjMapr'"
    have φr'_ArrVal_app[symmetric, cat_cs_simps]:
      "φNTMapr'ArrValf' =
        𝔉ArrMapf' A𝔅 φNTMaprArrVal𝔄CIdr"
      if "f' : r 𝔄 r'" for f'
    proof-
      have "φNTMapr' Acat_Set β HomO.Cβ𝔄(r,-)ArrMapf' =
        (HomO.Cβ𝔅(c,-) CF 𝔉)ArrMapf' Acat_Set β φNTMapr"
        using that by (intro φ.ntcf_Comp_commute)
      then have 
        "φNTMapr' Acat_Set β cf_hom 𝔄 [𝔄CIdr, f'] =
          cf_hom 𝔅 [𝔅CIdc, 𝔉ArrMapf'] Acat_Set β φNTMapr" 
        using assms(3,4) assms(1,2) that prems
        by (cs_prems cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
      then have
        "(φNTMapr' Acat_Set β
        cf_hom 𝔄 [𝔄CIdr, f'])ArrVal𝔄CIdr =
          (cf_hom 𝔅 [𝔅CIdc, 𝔉ArrMapf'] Acat_Set β
          φNTMapr)ArrVal𝔄CIdr"
        by simp
      from 
        this assms(3,4,2) u that HomDom.category_axioms HomCod.category_axioms
      show ?thesis
        by
          (
            cs_prems
              cs_simp: cat_cs_simps cat_op_simps 
              cs_intro:
                cat_cs_intros
                cat_op_intros
                cat_prod_cs_intros
                cat_Set_αβ.subcat_is_arrD
          )
    qed 
    
    show "∃!f'. f' : r 𝔄 r'  u' = umap_of 𝔉 c r ?u r'ArrValf'"
    proof(intro ex1I conjI; (elim conjE)?)
      from assms prems HomDom.category_axioms show 
        "(φNTMapr')¯Ccat_Set βArrValu' : r 𝔄 r'"
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_arrow_cs_intros
          )
      with assms(3,4) prems show "u' =
        umap_of 𝔉 c r ?u r'ArrVal(φNTMapr')¯Ccat_Set βArrValu'"
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_arrow_cs_intros cat_cs_intros cat_op_intros
          )
      fix f' assume prems': 
        "f' : r 𝔄 r'"
        "u' = umap_of 𝔉 c r (φNTMaprArrVal𝔄CIdr) r'ArrValf'"
      from prems'(2,1) assms(3,4) have u'_def: 
        "u' = 𝔉ArrMapf' A𝔅 φNTMaprArrVal𝔄CIdr"
        by
          (
            cs_prems
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros
          )
      from prems' show "f' = (φNTMapr')¯Ccat_Set βArrValu'"
        unfolding u'_def φr'_ArrVal_app[OF prems'(1)]
        by
          (
            cs_concl
              cs_simp: cat_cs_simps
              cs_intro: cat_arrow_cs_intros cat_cs_intros cat_op_intros
          )

    qed

  qed

qed

lemma (in is_functor) cf_universal_arrow_fo_if_is_iso_ntcf_if_ge_Limit:
  assumes "𝒵 β"
    and "α  β"
    and  "r  𝔄Obj"
    and "c  𝔅Obj"
    and "φ :
      HomO.Cβ𝔄(-,r) CF.iso HomO.Cβ𝔅(-,c) CF op_cf 𝔉 :
      op_cat 𝔄 ↦↦Cβ cat_Set β"
  shows "universal_arrow_fo 𝔉 c r (φNTMaprArrVal𝔄CIdr)"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  interpret β𝔉: is_functor β 𝔄 𝔅 𝔉
    by (rule cf_is_functor_if_ge_Limit)
      (use assms(2) in cs_concl cs_intro: cat_cs_intros)+
  show ?thesis 
    by 
      (
        rule is_functor.cf_universal_arrow_of_if_is_iso_ntcf_if_ge_Limit
          [
            OF is_functor_op,
            OF assms(1,2),
            unfolded cat_op_simps,
            OF assms(3,4),
            unfolded 
              β𝔉.HomDom.cat_op_cat_cf_Hom_snd[OF assms(3)] 
              β𝔉.HomCod.cat_op_cat_cf_Hom_snd[OF assms(4)]
              ntcf_ua_fo_def[symmetric],
            OF assms(5)
          ]
      )
qed

text‹\newpage›

end

Theory CZH_UCAT_Limit

(* Copyright 2021 (C) Mihails Milehins *)

section‹Limits›
theory CZH_UCAT_Limit
  imports 
    CZH_UCAT_Universal
    CZH_Elementary_Categories.CZH_ECAT_Discrete 
    CZH_Elementary_Categories.CZH_ECAT_SS
    CZH_Elementary_Categories.CZH_ECAT_Parallel
begin



subsection‹Background›

named_theorems cat_lim_cs_simps
named_theorems cat_lim_cs_intros



subsection‹Cone and cocone›


text‹
In the context of this work, the concept of a cone corresponds to that of a cone
to the base of a functor from a vertex, as defined in Chapter III-4 in
\cite{mac_lane_categories_2010}; the concept of a cocone corresponds to that
of a cone from the base of a functor to a vertex, as defined in Chapter III-3
in \cite{mac_lane_categories_2010}.

In this body of work, only limits and colimits of functors with tiny maps 
are considered. The definitions of a cone and a cocone also reflect this.
However, this restriction may be removed in the future.
›

(*TODO: remove the size limitation; see TODO in the next subsection*)
locale is_cat_cone = is_tm_ntcf α 𝔍  ‹cf_const 𝔍  c 𝔉 𝔑 for α c 𝔍  𝔉 𝔑 +
  assumes cat_cone_obj[cat_lim_cs_intros]: "c  Obj"

syntax "_is_cat_cone" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ <CF.cone _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "𝔑 : c <CF.cone 𝔉 : 𝔍 ↦↦Cα "  
  "CONST is_cat_cone α c 𝔍  𝔉 𝔑"

locale is_cat_cocone = is_tm_ntcf α 𝔍  𝔉 ‹cf_const 𝔍  c 𝔑 for α c 𝔍  𝔉 𝔑 +
  assumes cat_cocone_obj[cat_lim_cs_intros]: "c  Obj"

syntax "_is_cat_cocone" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ >CF.cocone _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 >CF.cocone c : 𝔍 ↦↦Cα "  
  "CONST is_cat_cocone α c 𝔍  𝔉 𝔑"


text‹Rules.›

lemma (in is_cat_cone) is_cat_cone_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "c' = c" and "𝔍' = 𝔍" and "ℭ' = " and "𝔉' = 𝔉"
  shows "𝔑 : c' <CF.cone 𝔉' : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_cone_axioms)

mk_ide rf is_cat_cone_def[unfolded is_cat_cone_axioms_def]
  |intro is_cat_coneI|
  |dest is_cat_coneD[dest!]|
  |elim is_cat_coneE[elim!]|

lemma (in is_cat_cone) is_cat_coneD'[cat_lim_cs_intros]:
  assumes "c' = cf_const 𝔍  c"
  shows "𝔑 : c' CF.tm 𝔉 : 𝔍 ↦↦C.tmα "
  unfolding assms by (cs_concl cs_intro: cat_small_cs_intros)

lemmas [cat_lim_cs_intros] = is_cat_cone.is_cat_coneD'

lemma (in is_cat_cocone) is_cat_cocone_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "c' = c" and "𝔍' = 𝔍" and "ℭ' = " and "𝔉' = 𝔉"
  shows "𝔑 : 𝔉' >CF.cocone c' : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_cocone_axioms)

mk_ide rf is_cat_cocone_def[unfolded is_cat_cocone_axioms_def]
  |intro is_cat_coconeI|
  |dest is_cat_coconeD[dest!]|
  |elim is_cat_coconeE[elim!]|

lemma (in is_cat_cocone) is_cat_coconeD'[cat_lim_cs_intros]:
  assumes "c' = cf_const 𝔍  c"
  shows "𝔑 : 𝔉 CF.tm c' : 𝔍 ↦↦C.tmα "
  unfolding assms by (cs_concl cs_intro: cat_small_cs_intros)

lemmas [cat_lim_cs_intros] = is_cat_cocone.is_cat_coconeD'


text‹Duality.›

lemma (in is_cat_cone) is_cat_cocone_op:
  "op_ntcf 𝔑 : op_cf 𝔉 >CF.cocone c : op_cat 𝔍 ↦↦Cα op_cat "
  by (intro is_cat_coconeI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_lim_cs_intros cat_op_intros)+

lemma (in is_cat_cone) is_cat_cocone_op'[cat_op_intros]:
  assumes "α' = α" and "𝔍' = op_cat 𝔍" and "ℭ' = op_cat " and "𝔉' = op_cf 𝔉"
  shows "op_ntcf 𝔑 : 𝔉' >CF.cocone c : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_cocone_op)

lemmas [cat_op_intros] = is_cat_cone.is_cat_cocone_op'

lemma (in is_cat_cocone) is_cat_cone_op:
  "op_ntcf 𝔑 : c <CF.cone op_cf 𝔉 : op_cat 𝔍 ↦↦Cα op_cat "
  by (intro is_cat_coneI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_lim_cs_intros cat_op_intros)

lemma (in is_cat_cocone) is_cat_cone_op'[cat_op_intros]:
  assumes "α' = α" and "𝔍' = op_cat 𝔍" and "ℭ' = op_cat " and "𝔉' = op_cf 𝔉"
  shows "op_ntcf 𝔑 : c <CF.cone 𝔉' : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_cone_op)

lemmas [cat_op_intros] = is_cat_cocone.is_cat_cone_op'


text‹Elementary properties.›

lemma (in is_cat_cone) cat_cone_LArr_app_is_arr: 
  assumes "j  𝔍Obj"
  shows "𝔑NTMapj : c  𝔉ObjMapj"
proof-
  from assms have [simp]: "cf_const 𝔍  cObjMapj = c"
    by (cs_concl cs_simp: cat_cs_simps)
  from ntcf_NTMap_is_arr[OF assms] show ?thesis by simp 
qed

lemma (in is_cat_cone) cat_cone_LArr_app_is_arr'[cat_lim_cs_intros]: 
  assumes "j  𝔍Obj" and "𝔉j = 𝔉ObjMapj"
  shows "𝔑NTMapj : c  𝔉j"
  using assms(1) unfolding assms(2) by (rule cat_cone_LArr_app_is_arr)

lemmas [cat_lim_cs_intros] = is_cat_cone.cat_cone_LArr_app_is_arr'

lemma (in is_cat_cocone) cat_cocone_LArr_app_is_arr: 
  assumes "j  𝔍Obj"
  shows "𝔑NTMapj : 𝔉ObjMapj  c"
proof-
  from assms have [simp]: "cf_const 𝔍  cObjMapj = c"
    by (cs_concl cs_simp: cat_cs_simps)
  from ntcf_NTMap_is_arr[OF assms] show ?thesis by simp 
qed

lemma (in is_cat_cocone) cat_cocone_LArr_app_is_arr'[cat_lim_cs_intros]: 
  assumes "j  𝔍Obj" and "𝔉j = 𝔉ObjMapj"
  shows "𝔑NTMapj : 𝔉j  c"
  using assms(1) unfolding assms(2) by (rule cat_cocone_LArr_app_is_arr)

lemmas [cat_lim_cs_intros] = is_cat_cocone.cat_cocone_LArr_app_is_arr'

lemma (in is_cat_cone) cat_cone_Comp_commute[cat_lim_cs_simps]:
  assumes "f : a 𝔍 b"
  shows "𝔉ArrMapf A 𝔑NTMapa = 𝔑NTMapb"
  using ntcf_Comp_commute[symmetric, OF assms] assms 
  by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemmas [cat_lim_cs_simps] = is_cat_cone.cat_cone_Comp_commute

lemma (in is_cat_cocone) cat_cocone_Comp_commute[cat_lim_cs_simps]:
  assumes "f : a 𝔍 b"
  shows "𝔑NTMapb A 𝔉ArrMapf = 𝔑NTMapa"
  using ntcf_Comp_commute[OF assms] assms 
  by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemmas [cat_lim_cs_simps] = is_cat_cocone.cat_cocone_Comp_commute


text‹Utilities/helper lemmas.›

lemma (in is_cat_cone) helper_cat_cone_ntcf_vcomp_Comp:
  assumes "𝔑' : c' <CF.cone 𝔉 : 𝔍 ↦↦Cα "
    and "f' : c'  c" 
    and "𝔑' = 𝔑 NTCF ntcf_const 𝔍  f'" 
    and "j  𝔍Obj"
  shows "𝔑'NTMapj = 𝔑NTMapj A f'"
proof-
  from assms(3) have "𝔑'NTMapj = (𝔑 NTCF ntcf_const 𝔍  f')NTMapj"
    by simp
  from this assms(1,2,4) show "𝔑'NTMapj = 𝔑NTMapj A f'"
    by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed

lemma (in is_cat_cone) helper_cat_cone_Comp_ntcf_vcomp:
  assumes "𝔑' : c' <CF.cone 𝔉 : 𝔍 ↦↦Cα "
    and "f' : c'  c" 
    and "j. j  𝔍Obj  𝔑'NTMapj = 𝔑NTMapj A f'" 
  shows "𝔑' = 𝔑 NTCF ntcf_const 𝔍  f'"
proof-
  interpret 𝔑': is_cat_cone α c' 𝔍  𝔉 𝔑' by (rule assms(1))
  show ?thesis
  proof(rule ntcf_eqI[OF 𝔑'.is_ntcf_axioms])
    from assms(2) show 
      "𝔑 NTCF ntcf_const 𝔍  f' : cf_const 𝔍  c' CF 𝔉 : 𝔍 ↦↦Cα "
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show "𝔑'NTMap = (𝔑 NTCF ntcf_const 𝔍  f')NTMap"
    proof(rule vsv_eqI, unfold cat_cs_simps)
      show "vsv ((𝔑 NTCF ntcf_const 𝔍  f')NTMap)"
        by (cs_concl cs_intro: cat_cs_intros)
      from assms show "𝔍Obj = 𝒟 ((𝔑 NTCF ntcf_const 𝔍  f')NTMap)"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      fix j assume prems': "j  𝔍Obj"
      with assms(1,2) show "𝔑'NTMapj = (𝔑 NTCF ntcf_const 𝔍  f')NTMapj"
        by (cs_concl cs_simp: cat_cs_simps assms(3) cs_intro: cat_cs_intros)
    qed auto
  qed simp_all
qed

lemma (in is_cat_cone) helper_cat_cone_Comp_ntcf_vcomp_iff:
  assumes "𝔑' : c' <CF.cone 𝔉 : 𝔍 ↦↦Cα "
  shows "f' : c'  c  𝔑' = 𝔑 NTCF ntcf_const 𝔍  f' 
    f' : c'  c  (j𝔍Obj. 𝔑'NTMapj = 𝔑NTMapj A f')"
  using 
    helper_cat_cone_ntcf_vcomp_Comp[OF assms]
    helper_cat_cone_Comp_ntcf_vcomp[OF assms]
  by (intro iffI; elim conjE; intro conjI) metis+

lemma (in is_cat_cocone) helper_cat_cocone_ntcf_vcomp_Comp:
  assumes "𝔑' : 𝔉 >CF.cocone c' : 𝔍 ↦↦Cα "
    and "f' : c  c'" 
    and "𝔑' = ntcf_const 𝔍  f' NTCF 𝔑" 
    and "j  𝔍Obj"
  shows "𝔑'NTMapj = f' A 𝔑NTMapj"
proof-
  interpret 𝔑': is_cat_cocone α c' 𝔍  𝔉 𝔑' by (rule assms(1))
  from assms(3) have "op_ntcf 𝔑' = op_ntcf (ntcf_const 𝔍  f' NTCF 𝔑)" by simp
  from this assms(2) have op_𝔑':
    "op_ntcf 𝔑' = op_ntcf 𝔑 NTCF ntcf_const (op_cat 𝔍) (op_cat ) f'"
    by (cs_prems cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros)
  have "𝔑'NTMapj = 𝔑NTMapj Aop_cat  f'"
    by 
      (
        rule is_cat_cone.helper_cat_cone_ntcf_vcomp_Comp[
          OF is_cat_cone_op 𝔑'.is_cat_cone_op, 
          unfolded cat_op_simps, 
          OF assms(2) op_𝔑' assms(4)
          ]
      )
  from this assms(2,4) show "𝔑'NTMapj = f' A 𝔑NTMapj"
    by (cs_prems cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
qed

lemma (in is_cat_cocone) helper_cat_cocone_Comp_ntcf_vcomp:
  assumes "𝔑' : 𝔉 >CF.cocone c' : 𝔍 ↦↦Cα "
    and "f' : c  c'" 
    and "j. j  𝔍Obj  𝔑'NTMapj = f' A 𝔑NTMapj" 
  shows "𝔑' = ntcf_const 𝔍  f' NTCF 𝔑"
proof-
  interpret 𝔑': is_cat_cocone α c' 𝔍  𝔉 𝔑' by (rule assms(1))
  from assms(2) have 𝔑'j: "𝔑'NTMapj = 𝔑NTMapj Aop_cat  f'"
    if "j  𝔍Obj" for j
    using that
    unfolding assms(3)[OF that] 
    by (cs_concl cs_simp: cat_op_simps cat_cs_simps cs_intro: cat_cs_intros)
  have op_𝔑': 
    "op_ntcf 𝔑' = op_ntcf 𝔑 NTCF ntcf_const (op_cat 𝔍) (op_cat ) f'"
    by 
      (
        rule is_cat_cone.helper_cat_cone_Comp_ntcf_vcomp[
          OF is_cat_cone_op 𝔑'.is_cat_cone_op,
          unfolded cat_op_simps, 
          OF assms(2) 𝔑'j, 
          simplified
          ]
      )
  from assms(2) show "𝔑' = (ntcf_const 𝔍  f' NTCF 𝔑)"
    by 
      (
        cs_concl 
          cs_simp: 
            cat_op_simps op_𝔑' eq_op_ntcf_iff[symmetric, OF 𝔑'.is_ntcf_axioms]
          cs_intro: cat_cs_intros
      )
qed

lemma (in is_cat_cocone) helper_cat_cocone_Comp_ntcf_vcomp_iff:
  assumes "𝔑' : 𝔉 >CF.cocone c' : 𝔍 ↦↦Cα "
  shows "f' : c  c'  𝔑' = ntcf_const 𝔍  f' NTCF 𝔑 
    f' : c  c'  (j𝔍Obj. 𝔑'NTMapj = f' A 𝔑NTMapj)"
  using 
    helper_cat_cocone_ntcf_vcomp_Comp[OF assms]
    helper_cat_cocone_Comp_ntcf_vcomp[OF assms]
  by (intro iffI; elim conjE; intro conjI) metis+



subsection‹Limit and colimit›


subsubsection‹Definition and elementary properties›


text‹
The concept of a limit is introduced in Chapter III-4 in
\cite{mac_lane_categories_2010}; the concept of a colimit is introduced in
Chapter III-3 in \cite{mac_lane_categories_2010}.
›

(*TODO: remove the size limitation*)
locale is_cat_limit = is_cat_cone α r 𝔍  𝔉 u for α 𝔍  𝔉 r u +
  assumes cat_lim_ua_fo: 
    "universal_arrow_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u)"

syntax "_is_cat_limit" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ <CF.lim _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "  
  "CONST is_cat_limit α 𝔍  𝔉 r u"

locale is_cat_colimit = is_cat_cocone α r 𝔍  𝔉 u for α 𝔍  𝔉 r u +
  assumes cat_colim_ua_fo: "universal_arrow_fo 
    (ΔC α (op_cat 𝔍) (op_cat )) (cf_map 𝔉) r (ntcf_arrow (op_ntcf u))"

syntax "_is_cat_colimit" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ >CF.colim _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα "  
  "CONST is_cat_colimit α 𝔍  𝔉 r u"


text‹Rules.›

lemma (in is_cat_limit) is_cat_limit_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "r' = r" and "𝔍' = 𝔍" and "ℭ' = " and "𝔉' = 𝔉"
  shows "u : r' <CF.lim 𝔉' : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_limit_axioms)

mk_ide rf is_cat_limit_def[unfolded is_cat_limit_axioms_def]
  |intro is_cat_limitI|
  |dest is_cat_limitD[dest]|
  |elim is_cat_limitE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_limitD(1)

lemma (in is_cat_colimit) is_cat_colimit_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "r' = r" and "𝔍' = 𝔍" and "ℭ' = " and "𝔉' = 𝔉"
  shows "u : 𝔉' >CF.colim r' : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_colimit_axioms)

mk_ide rf is_cat_colimit_def[unfolded is_cat_colimit_axioms_def]
  |intro is_cat_colimitI|
  |dest is_cat_colimitD[dest]|
  |elim is_cat_colimitE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_colimitD(1)


text‹Duality›

lemma (in is_cat_limit) is_cat_colimit_op:
  "op_ntcf u : op_cf 𝔉 >CF.colim r : op_cat 𝔍 ↦↦Cα op_cat "
  using cat_lim_ua_fo
  by (intro is_cat_colimitI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros)

lemma (in is_cat_limit) is_cat_colimit_op'[cat_op_intros]:
  assumes "𝔉' = op_cf 𝔉" and "𝔍' = op_cat 𝔍" and "ℭ' = op_cat "
  shows "op_ntcf u : 𝔉' >CF.colim r : 𝔍' ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_colimit_op)

lemmas [cat_op_intros] = is_cat_limit.is_cat_colimit_op'

lemma (in is_cat_colimit) is_cat_limit_op:
  "op_ntcf u : r <CF.lim op_cf 𝔉 : op_cat 𝔍 ↦↦Cα op_cat "
  using cat_colim_ua_fo
  by (intro is_cat_limitI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros)

lemma (in is_cat_colimit) is_cat_colimit_op'[cat_op_intros]:
  assumes "𝔉' = op_cf 𝔉" and "𝔍' = op_cat 𝔍" and "ℭ' = op_cat "
  shows "op_ntcf u : r <CF.lim 𝔉' : 𝔍' ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_limit_op)

lemmas [cat_op_intros] = is_cat_colimit.is_cat_colimit_op'


text‹Elementary properties of limits and colimits.›

sublocale is_cat_limit  Δ: is_functor α  ‹cat_Funct α 𝔍  ΔC α 𝔍 
  by (cs_concl cs_intro: cat_cs_intros cat_small_cs_intros)

sublocale is_cat_colimit  Δ: is_functor 
  α ‹op_cat  ‹cat_Funct α (op_cat 𝔍) (op_cat ) ΔC α (op_cat 𝔍) (op_cat )
  by (cs_concl cs_intro: cat_small_cs_intros cat_cs_intros cat_op_intros)


subsubsection‹Universal property›

lemma is_cat_limitI':
  assumes "u : r <CF.cone 𝔉 : 𝔍 ↦↦Cα " 
    and "u' r'.  u' : r' <CF.cone 𝔉 : 𝔍 ↦↦Cα    
      ∃!f'. f' : r'  r  u' = u NTCF ntcf_const 𝔍  f'"
  shows "u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "
proof(intro is_cat_limitI is_functor.universal_arrow_foI)
  interpret u: is_cat_cone α r 𝔍  𝔉 u by (rule assms(1))
  show "r  Obj" by (cs_concl cs_intro: cat_lim_cs_intros)
  show "ΔC α 𝔍  :  ↦↦Cα cat_Funct α 𝔍 "
    by (cs_concl cs_intro: cat_cs_intros cat_small_cs_intros)
  show "ntcf_arrow u : ΔC α 𝔍 ObjMapr cat_Funct α 𝔍  cf_map 𝔉"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_lim_cs_intros cat_small_cs_intros cat_FUNCT_cs_intros
      )
  fix r' u' assume prems: 
    "r'  Obj" "u' : ΔC α 𝔍 ObjMapr' cat_Funct α 𝔍  cf_map 𝔉"
  note u' = cat_Funct_is_arrD[OF prems(2)]
  from u'(1) prems(1) have u'_is_tm_ntcf:
    "ntcf_of_ntcf_arrow 𝔍  u' : cf_const 𝔍  r' CF.tm 𝔉 : 𝔍 ↦↦C.tmα "
    by 
      (
        cs_prems 
          cs_simp: cat_cs_simps cat_small_cs_simps cat_FUNCT_cs_simps 
          cs_intro: cat_cs_intros
      )
  from this prems(1) have u'_is_cat_cone: 
    "ntcf_of_ntcf_arrow 𝔍  u' : r' <CF.cone 𝔉 : 𝔍 ↦↦Cα "
    by (intro is_cat_coneI)
  interpret u': is_cat_cone α r' 𝔍  𝔉 ‹ntcf_of_ntcf_arrow 𝔍  u'
    by (rule u'_is_cat_cone)
  from assms(2)[OF u'_is_cat_cone] obtain f' where f': "f' : r'  r"
    and u'_def: "ntcf_of_ntcf_arrow 𝔍  u' = u NTCF ntcf_const 𝔍  f'"
    and unique: "f''.
      
        f'' : r'  r; 
        ntcf_of_ntcf_arrow 𝔍  u' = u NTCF ntcf_const 𝔍  f''
        f'' = f'"
    by (meson prems(1))
  from u'_def have u'_NTMap_app:
    "ntcf_of_ntcf_arrow 𝔍  u'NTMapj = (u NTCF ntcf_const 𝔍  f')NTMapj"
    if "j  𝔍Obj" for j 
    by simp
  have u'_NTMap_app: "u'NTMapj = uNTMapj A f'"
    if "j  𝔍Obj" for j 
    using u'_NTMap_app[OF that] that f'
    by (cs_prems cs_simp: cat_cs_simps cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
  show "∃!f'.
    f' : r'  r 
    u' = umap_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u) r'ArrValf'"
  proof(intro ex1I conjI; (elim conjE)?)
    show "f' : r'  r" by (rule f')
    have u'_def'[symmetric, cat_cs_simps]: 
      "ntcf_of_ntcf_arrow 𝔍  u' = u NTCF ntcf_const 𝔍  f'"
    proof(rule ntcf_eqI)
      from u'_is_tm_ntcf show 
        "ntcf_of_ntcf_arrow 𝔍  u' : cf_const 𝔍  r' CF 𝔉 : 𝔍 ↦↦Cα "
        by (cs_concl cs_intro: cat_small_cs_intros)
      from f' show 
        "u NTCF ntcf_const 𝔍  f' : cf_const 𝔍  r' CF 𝔉 : 𝔍 ↦↦Cα "
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show 
        "ntcf_of_ntcf_arrow 𝔍  u'NTMap = (u NTCF ntcf_const 𝔍  f')NTMap"
      proof(rule vsv_eqI)
        from f' show "𝒟 (ntcf_of_ntcf_arrow 𝔍  u'NTMap) = 
          𝒟 ((u NTCF ntcf_const 𝔍  f')NTMap)"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)    
        show "ntcf_of_ntcf_arrow 𝔍  u'NTMapa = 
          (u NTCF ntcf_const 𝔍  f')NTMapa"
          if "a  𝒟 (ntcf_of_ntcf_arrow 𝔍  u'NTMap)" for a
        proof-
          from that have "a  𝔍Obj" by (cs_prems cs_simp: cat_cs_simps)    
          with f' show 
            "ntcf_of_ntcf_arrow 𝔍  u'NTMapa =
              (u NTCF ntcf_const 𝔍  f')NTMapa"
            by 
              (
                cs_concl 
                  cs_simp: cat_cs_simps cat_FUNCT_cs_simps u'_NTMap_app 
                  cs_intro: cat_cs_intros
              )
        qed
      qed (auto intro: cat_cs_intros)
    qed simp_all
    from f' u'(1) show 
      "u' = umap_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u) r'ArrValf'"
      by (subst u'(2))
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps 
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_small_cs_intros
        )
    fix f'' assume prems': 
      "f'' : r'  r"
      "u' = umap_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u) r'ArrValf''"  
    from prems'(2,1) u'(1) have 
      "ntcf_of_ntcf_arrow 𝔍  u' = u NTCF ntcf_const 𝔍  f''"
      by (subst (asm) u'(2))
        (
          cs_prems 
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps 
            cs_intro: cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
        )
    from unique[OF prems'(1) this] show "f'' = f'" .
  qed
qed (intro assms)+

lemma (in is_cat_limit) cat_lim_unique_cone:
  assumes "u' : r' <CF.cone 𝔉 : 𝔍 ↦↦Cα " 
  shows "∃!f'. f' : r'  r  u' = u NTCF ntcf_const 𝔍  f'"
proof-
  interpret u': is_cat_cone α r' 𝔍  𝔉 u' by (rule assms(1))
  have "ntcf_arrow u' : ΔC α 𝔍 ObjMapr' cat_Funct α 𝔍  cf_map 𝔉"
    by 
      (
        cs_concl 
          cs_intro: cat_lim_cs_intros cat_FUNCT_cs_intros cs_simp: cat_cs_simps
      )
  from Δ.universal_arrow_foD(3)[OF cat_lim_ua_fo u'.cat_cone_obj this] obtain f'
    where f': "f' : r'  r" 
      and u': "ntcf_arrow u' =
      umap_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u) r'ArrValf'"
      and unique:
        "
          f'' : r'  r;
          ntcf_arrow u' =
            umap_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u) r'ArrValf''
           f'' = f'"
    for f''
    by metis
  show "∃!f'. f' : r'  r  u' = u NTCF ntcf_const 𝔍  f'"
  proof(intro ex1I conjI; (elim conjE)?)
    show "f' : r'  r" by (rule f')
    with u' show "u' = u NTCF ntcf_const 𝔍  f'"
      by 
        (
          cs_prems 
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_small_cs_intros
        )
    fix f'' assume prems: "f'' : r'  r"  "u' = u NTCF ntcf_const 𝔍  f''"
    from prems(1) have "ntcf_arrow u' =
      umap_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u) r'ArrValf''"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps prems(2)[symmetric] 
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_small_cs_intros
        )
    from prems(1) this show "f'' = f'" by (intro unique)
  qed
qed  

lemma (in is_cat_limit) cat_lim_unique_cone':
  assumes "u' : r' <CF.cone 𝔉 : 𝔍 ↦↦Cα "
  shows 
    "∃!f'. f' : r'  r  (j𝔍Obj. u'NTMapj = uNTMapj A f')"
  by (fold helper_cat_cone_Comp_ntcf_vcomp_iff[OF assms(1)])
    (intro cat_lim_unique_cone assms)

lemma (in is_cat_limit) cat_lim_unique:
  assumes "u' : r' <CF.lim 𝔉 : 𝔍 ↦↦Cα "
  shows "∃!f'. f' : r'  r  u' = u NTCF ntcf_const 𝔍  f'"
  by (intro cat_lim_unique_cone[OF is_cat_limitD(1)[OF assms]])

lemma (in is_cat_limit) cat_lim_unique':
  assumes "u' : r' <CF.lim 𝔉 : 𝔍 ↦↦Cα "
  shows 
    "∃!f'. f' : r'  r  (j𝔍Obj. u'NTMapj = uNTMapj A f')"
  by (intro cat_lim_unique_cone'[OF is_cat_limitD(1)[OF assms]])

lemma (in is_cat_colimit) cat_colim_unique_cocone:
  assumes "u' : 𝔉 >CF.cocone r' : 𝔍 ↦↦Cα "
  shows "∃!f'. f' : r  r'  u' = ntcf_const 𝔍  f' NTCF u"
proof-
  interpret u': is_cat_cocone α r' 𝔍  𝔉 u' by (rule assms(1))
  from u'.cat_cocone_obj have op_r': "r'  op_cat Obj"
    unfolding cat_op_simps by simp
  from 
    is_cat_limit.cat_lim_unique_cone[
      OF is_cat_limit_op u'.is_cat_cone_op, folded op_ntcf_ntcf_const
      ]
  obtain f' where f': "f' : r' op_cat  r"
    and [cat_cs_simps]: 
      "op_ntcf u' = op_ntcf u NTCF op_ntcf (ntcf_const 𝔍  f')"
    and unique: 
      "
        f'' : r' op_cat  r;
        op_ntcf u' = op_ntcf u NTCF op_ntcf (ntcf_const 𝔍  f'')
         f'' = f'" 
    for f''
    by metis
  show ?thesis
  proof(intro ex1I conjI; (elim conjE)?)
    from f' show f': "f' : r  r'" unfolding cat_op_simps by simp
    show "u' = ntcf_const 𝔍  f' NTCF u"
      by (rule eq_op_ntcf_iff[THEN iffD1], insert f')
        (cs_concl cs_intro: cat_cs_intros cs_simp: cat_cs_simps cat_op_simps)+
    fix f'' assume prems: "f'' : r  r'" "u' = ntcf_const 𝔍  f'' NTCF u"
    from prems(1) have "f'' : r' op_cat  r" unfolding cat_op_simps by simp
    moreover from prems(1) have 
      "op_ntcf u' = op_ntcf u NTCF op_ntcf (ntcf_const 𝔍  f'')"
      unfolding prems(2)
      by (cs_concl cs_intro: cat_cs_intros cs_simp: cat_cs_simps cat_op_simps)
    ultimately show "f'' = f'" by (rule unique)
  qed
qed

lemma (in is_cat_colimit) cat_colim_unique_cocone':
  assumes "u' : 𝔉 >CF.cocone r' : 𝔍 ↦↦Cα "
  shows 
    "∃!f'. f' : r  r'  (j𝔍Obj. u'NTMapj = f' A uNTMapj)"
  by (fold helper_cat_cocone_Comp_ntcf_vcomp_iff[OF assms(1)])
    (intro cat_colim_unique_cocone assms)

lemma (in is_cat_colimit) cat_colim_unique:
  assumes "u' : 𝔉 >CF.colim r' : 𝔍 ↦↦Cα "
  shows "∃!f'. f' : r  r'  u' = ntcf_const 𝔍  f' NTCF u"
  by (intro cat_colim_unique_cocone[OF is_cat_colimitD(1)[OF assms]])

lemma (in is_cat_colimit) cat_colim_unique':
  assumes "u' : 𝔉 >CF.colim r' : 𝔍 ↦↦Cα "
  shows
    "∃!f'. f' : r  r'  (j𝔍Obj. u'NTMapj = f' A uNTMapj)"
proof-
  interpret u': is_cat_colimit α 𝔍  𝔉 r' u' by (rule assms(1))
  show ?thesis
    by (fold helper_cat_cocone_Comp_ntcf_vcomp_iff[OF u'.is_cat_cocone_axioms])
      (intro cat_colim_unique assms)
qed

lemma cat_lim_ex_is_arr_isomorphism:
  assumes "u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα " 
    and "u' : r' <CF.lim 𝔉 : 𝔍 ↦↦Cα "
  obtains f where "f : r' iso r" and "u' = u NTCF ntcf_const 𝔍  f"
proof-
  interpret u: is_cat_limit α 𝔍  𝔉 r u by (rule assms(1))
  interpret u': is_cat_limit α 𝔍  𝔉 r' u' by (rule assms(2))
  obtain f where f: "f : r' iso r"
    and u': "ntcf_arrow u' =
    umap_fo (ΔC α 𝔍 ) (cf_map 𝔉) r (ntcf_arrow u) r'ArrValf"
    by 
      (
        elim u.Δ.cf_universal_arrow_fo_ex_is_arr_isomorphism[
          OF u.cat_lim_ua_fo u'.cat_lim_ua_fo
          ]
      )
  from f have "f : r'  r" by auto
  from u' this have "u' = u NTCF ntcf_const 𝔍  f"
    by
      (
        cs_prems
          cs_simp: cat_cs_simps cat_FUNCT_cs_simps cat_small_cs_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_small_cs_intros
      )
  with f that show ?thesis by simp
qed

lemma cat_lim_ex_is_arr_isomorphism':
  assumes "u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα " 
    and "u' : r' <CF.lim 𝔉 : 𝔍 ↦↦Cα "
  obtains f where "f : r' iso r" 
    and "j. j  𝔍Obj  u'NTMapj = uNTMapj A f"
proof-
  interpret u: is_cat_limit α 𝔍  𝔉 r u by (rule assms(1))
  interpret u': is_cat_limit α 𝔍  𝔉 r' u' by (rule assms(2))
  from assms obtain f 
    where iso_f: "f : r' iso r" and u'_def: "u' = u NTCF ntcf_const 𝔍  f"
    by (rule cat_lim_ex_is_arr_isomorphism)
  then have f: "f : r'  r" by auto
  then have "u'NTMapj = uNTMapj A f" if "j  𝔍Obj" for j
    by 
      (
        intro u.helper_cat_cone_ntcf_vcomp_Comp[
          OF u'.is_cat_cone_axioms f u'_def that
          ]
      )
  with iso_f that show ?thesis by simp
qed

lemma cat_colim_ex_is_arr_isomorphism:
  assumes "u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα " 
    and "u' : 𝔉 >CF.colim r' : 𝔍 ↦↦Cα "
  obtains f where "f : r iso r'" and "u' = ntcf_const 𝔍  f NTCF u"
proof-
  interpret u: is_cat_colimit α 𝔍  𝔉 r u by (rule assms(1))
  interpret u': is_cat_colimit α 𝔍  𝔉 r' u' by (rule assms(2))
  obtain f where f: "f : r' isoop_cat  r"
    and [cat_cs_simps]: 
      "op_ntcf u' = op_ntcf u NTCF ntcf_const (op_cat 𝔍) (op_cat ) f"
    by 
      (
        elim cat_lim_ex_is_arr_isomorphism[
          OF u.is_cat_limit_op u'.is_cat_limit_op
          ]
      )
  from f have iso_f: "f : r iso r'" unfolding cat_op_simps by simp
  then have f: "f : r  r'" by auto
  have "u' = ntcf_const 𝔍  f NTCF u"
    by (rule eq_op_ntcf_iff[THEN iffD1], insert f)
      (cs_concl cs_intro: cat_cs_intros cs_simp: cat_cs_simps cat_op_simps)+
  from iso_f this that show ?thesis by simp
qed

lemma cat_colim_ex_is_arr_isomorphism':
  assumes "u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα " 
    and "u' : 𝔉 >CF.colim r' : 𝔍 ↦↦Cα "
  obtains f where "f : r iso r'"
    and "j. j  𝔍Obj  u'NTMapj = f A uNTMapj"
proof-
  interpret u: is_cat_colimit α 𝔍  𝔉 r u by (rule assms(1))
  interpret u': is_cat_colimit α 𝔍  𝔉 r' u' by (rule assms(2))
  from assms obtain f 
    where iso_f: "f : r iso r'" and u'_def: "u' = ntcf_const 𝔍  f NTCF u"
    by (rule cat_colim_ex_is_arr_isomorphism)
  then have f: "f : r  r'" by auto
  then have "u'NTMapj = f A uNTMapj" if "j  𝔍Obj" for j
    by 
      (
        intro u.helper_cat_cocone_ntcf_vcomp_Comp[
          OF u'.is_cat_cocone_axioms f u'_def that
          ]
      )
  with iso_f that show ?thesis by simp
qed



subsection‹Finite limit and finite colimit›

locale is_cat_finite_limit = is_cat_limit α 𝔍  𝔉 r u + finite_category α 𝔍
  for α 𝔍  𝔉 r u

syntax "_is_cat_finite_limit" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ <CF.lim.fin _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "u : r <CF.lim.fin 𝔉 : 𝔍 ↦↦Cα "  
  "CONST is_cat_finite_limit α 𝔍  𝔉 r u"

locale is_cat_finite_colimit = is_cat_colimit α 𝔍  𝔉 r u + finite_category α 𝔍
  for α 𝔍  𝔉 r u

syntax "_is_cat_finite_colimit" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ >CF.colim.fin _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "u : 𝔉 >CF.colim.fin r : 𝔍 ↦↦Cα "  
  "CONST is_cat_finite_colimit α 𝔍  𝔉 r u"


text‹Rules.›

lemma (in is_cat_finite_limit) is_cat_finite_limit_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "r' = r" and "𝔍' = 𝔍" and "ℭ' = " and "𝔉' = 𝔉"
  shows "u : r' <CF.lim.fin 𝔉' : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_finite_limit_axioms)

mk_ide rf is_cat_finite_limit_def
  |intro is_cat_finite_limitI|
  |dest is_cat_finite_limitD[dest]|
  |elim is_cat_finite_limitE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_finite_limitD

lemma (in is_cat_finite_colimit) 
  is_cat_finite_colimit_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "r' = r" and "𝔍' = 𝔍" and "ℭ' = " and "𝔉' = 𝔉"
  shows "u : 𝔉' >CF.colim.fin r' : 𝔍' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_finite_colimit_axioms)

mk_ide rf is_cat_finite_colimit_def[unfolded is_cat_colimit_axioms_def]
  |intro is_cat_finite_colimitI|
  |dest is_cat_finite_colimitD[dest]|
  |elim is_cat_finite_colimitE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_finite_colimitD


text‹Duality›

lemma (in is_cat_finite_limit) is_cat_finite_colimit_op:
  "op_ntcf u : op_cf 𝔉 >CF.colim.fin r : op_cat 𝔍 ↦↦Cα op_cat "
  by 
    (
      cs_concl cs_intro:
        is_cat_finite_colimitI cat_op_intros cat_small_cs_intros
    )

lemma (in is_cat_finite_limit) is_cat_finite_colimit_op'[cat_op_intros]:
  assumes "𝔉' = op_cf 𝔉" and "𝔍' = op_cat 𝔍" and "ℭ' = op_cat "
  shows "op_ntcf u : 𝔉' >CF.colim.fin r : 𝔍' ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_finite_colimit_op)

lemmas [cat_op_intros] = is_cat_finite_limit.is_cat_finite_colimit_op'

lemma (in is_cat_finite_colimit) is_cat_finite_limit_op:
  "op_ntcf u : r <CF.lim.fin op_cf 𝔉 : op_cat 𝔍 ↦↦Cα op_cat "
  by 
    (
      cs_concl cs_intro: 
        is_cat_finite_limitI cat_op_intros cat_small_cs_intros
    )

lemma (in is_cat_finite_colimit) is_cat_finite_colimit_op'[cat_op_intros]:
  assumes "𝔉' = op_cf 𝔉" and "𝔍' = op_cat 𝔍" and "ℭ' = op_cat "
  shows "op_ntcf u : r <CF.lim.fin 𝔉' : 𝔍' ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_finite_limit_op)

lemmas [cat_op_intros] = is_cat_finite_colimit.is_cat_finite_colimit_op'



subsection‹Product and coproduct›


subsubsection‹Definition and elementary properties›


text‹
The definition of the product object is a specialization of the 
definition presented in Chapter III-4 in \cite{mac_lane_categories_2010}.
In the definition presented below, the discrete category that is used in the 
definition presented in \cite{mac_lane_categories_2010} is parameterized by
an index set and the functor from the discrete category is 
parameterized by a function from the index set to the set of 
the objects of the category.
›

locale is_cat_obj_prod = 
  is_cat_limit α :C I  :→: I A  P π + cf_discrete α I A 
  for α I A  P π

syntax "_is_cat_obj_prod" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ <CF. _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "π : P <CF. A : I ↦↦Cα "  
  "CONST is_cat_obj_prod α I A  P π"

locale is_cat_obj_coprod = 
  is_cat_colimit α :C I  :→: I A  U π + cf_discrete α I A 
  for α I A  U π

syntax "_is_cat_obj_coprod" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ >CF. _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "π : A >CF. U : I ↦↦Cα "  
  "CONST is_cat_obj_coprod α I A  U π"


text‹Rules.›

lemma (in is_cat_obj_prod) is_cat_obj_prod_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "P' = P" and "A' = A" and "I' = I" and "ℭ' = " 
  shows "π : P' <CF. A' : I' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_obj_prod_axioms)

mk_ide rf is_cat_obj_prod_def
  |intro is_cat_obj_prodI|
  |dest is_cat_obj_prodD[dest]|
  |elim is_cat_obj_prodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_prodD

lemma (in is_cat_obj_coprod) is_cat_obj_coprod_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "U' = U" and "A' = A" and "I' = I" and "ℭ' = " 
  shows "π : A' >CF. U' : I' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_obj_coprod_axioms)

mk_ide rf is_cat_obj_coprod_def
  |intro is_cat_obj_coprodI|
  |dest is_cat_obj_coprodD[dest]|
  |elim is_cat_obj_coprodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_coprodD


text‹Duality.›

lemma (in is_cat_obj_prod) is_cat_obj_coprod_op:
  "op_ntcf π : A >CF. P : I ↦↦Cα op_cat "
  using cf_discrete_vdomain_vsubset_Vset
  by (intro is_cat_obj_coprodI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros)

lemma (in is_cat_obj_prod) is_cat_obj_coprod_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf π : A >CF. P : I ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_obj_coprod_op)

lemmas [cat_op_intros] = is_cat_obj_prod.is_cat_obj_coprod_op'

lemma (in is_cat_obj_coprod) is_cat_obj_prod_op:
  "op_ntcf π : U <CF. A : I ↦↦Cα op_cat "
  using cf_discrete_vdomain_vsubset_Vset
  by (intro is_cat_obj_prodI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros)

lemma (in is_cat_obj_coprod) is_cat_obj_prod_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf π : U <CF. A : I ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_obj_prod_op)

lemmas [cat_op_intros] = is_cat_obj_coprod.is_cat_obj_prod_op'


subsubsection‹Universal property›

(*cat_obj_prod_unique_cone already proven*)
lemma (in is_cat_obj_prod) cat_obj_prod_unique_cone':
  assumes "π' : P' <CF.cone :→: I A  : :C I ↦↦Cα "
  shows "∃!f'. f' : P'  P  (jI. π'NTMapj = πNTMapj A f')"
  by 
    (
      rule cat_lim_unique_cone'[
        OF assms, unfolded the_cat_discrete_components(1)
        ]
    )

lemma (in is_cat_obj_prod) cat_obj_prod_unique:
  assumes "π' : P' <CF. A : I ↦↦Cα "
  shows "∃!f'. f' : P'  P  π' = π NTCF ntcf_const (:C I)  f'"
  by (intro cat_lim_unique[OF is_cat_obj_prodD(1)[OF assms]])

lemma (in is_cat_obj_prod) cat_obj_prod_unique':
  assumes "π' : P' <CF. A : I ↦↦Cα "
  shows "∃!f'. f' : P'  P  (iI. π'NTMapi = πNTMapi A f')"
proof-
  interpret π': is_cat_obj_prod α I A  P' π' by (rule assms(1))
  show ?thesis
    by 
      (
        rule cat_lim_unique'[
          OF π'.is_cat_limit_axioms, unfolded the_cat_discrete_components(1)
          ]
      )
qed

lemma (in is_cat_obj_coprod) cat_obj_coprod_unique_cocone':
  assumes "π' : :→: I A  >CF.cocone U' : :C I ↦↦Cα "
  shows "∃!f'. f' : U  U'  (jI. π'NTMapj = f' A πNTMapj)"
  by 
    (
      rule cat_colim_unique_cocone'[
        OF assms, unfolded the_cat_discrete_components(1)
        ]
    )

lemma (in is_cat_obj_coprod) cat_obj_coprod_unique:
  assumes "π' : A >CF. U' : I ↦↦Cα "
  shows "∃!f'. f' : U  U'  π' = ntcf_const (:C I)  f' NTCF π"
  by (intro cat_colim_unique[OF is_cat_obj_coprodD(1)[OF assms]])

lemma (in is_cat_obj_coprod) cat_obj_coprod_unique':
  assumes "π' : A >CF. U' : I ↦↦Cα "
  shows "∃!f'. f' : U  U'  (jI. π'NTMapj = f' A πNTMapj)"
  by 
    (
      rule cat_colim_unique'[
        OF is_cat_obj_coprodD(1)[OF assms], unfolded the_cat_discrete_components
        ]
    )

lemma cat_obj_prod_ex_is_arr_isomorphism:
  assumes "π : P <CF. A : I ↦↦Cα " and "π' : P' <CF. A : I ↦↦Cα "
  obtains f where "f : P' iso P" and "π' = π NTCF ntcf_const (:C I)  f"
proof-
  interpret π: is_cat_obj_prod α I A  P π by (rule assms(1))
  interpret π': is_cat_obj_prod α I A  P' π' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_lim_ex_is_arr_isomorphism[
          OF π.is_cat_limit_axioms π'.is_cat_limit_axioms
          ]
      )
qed

lemma cat_obj_prod_ex_is_arr_isomorphism':
  assumes "π : P <CF. A : I ↦↦Cα " and "π' : P' <CF. A : I ↦↦Cα "
  obtains f where "f : P' iso P" 
    and "j. j  I  π'NTMapj = πNTMapj A f"
proof-
  interpret π: is_cat_obj_prod α I A  P π by (rule assms(1))
  interpret π': is_cat_obj_prod α I A  P' π' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_lim_ex_is_arr_isomorphism'[
          OF π.is_cat_limit_axioms π'.is_cat_limit_axioms,
          unfolded the_cat_discrete_components(1)
          ]
      )
qed

lemma cat_obj_coprod_ex_is_arr_isomorphism:
  assumes "π : A >CF. U : I ↦↦Cα " and "π' : A >CF. U' : I ↦↦Cα "
  obtains f where "f : U iso U'" and "π' = ntcf_const (:C I)  f NTCF π"
proof-
  interpret π: is_cat_obj_coprod α I A  U π by (rule assms(1))
  interpret π': is_cat_obj_coprod α I A  U' π' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_colim_ex_is_arr_isomorphism[
          OF π.is_cat_colimit_axioms π'.is_cat_colimit_axioms
          ]
      )
qed

lemma cat_obj_coprod_ex_is_arr_isomorphism':
  assumes "π : A >CF. U : I ↦↦Cα " and "π' : A >CF. U' : I ↦↦Cα "
  obtains f where "f : U iso U'" 
    and "j. j  I  π'NTMapj = f A πNTMapj"
proof-
  interpret π: is_cat_obj_coprod α I A  U π by (rule assms(1))
  interpret π': is_cat_obj_coprod α I A  U' π' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_colim_ex_is_arr_isomorphism'[
          OF π.is_cat_colimit_axioms π'.is_cat_colimit_axioms,
          unfolded the_cat_discrete_components(1)
          ]
      )
qed



subsection‹Finite product and finite coproduct›

locale is_cat_finite_obj_prod = is_cat_obj_prod α I A  P π 
  for α I A  P π +
  assumes cat_fin_obj_prod_index_in_ω: "I  ω" 

syntax "_is_cat_finite_obj_prod" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ <CF..fin _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "π : P <CF..fin A : I ↦↦Cα "  
  "CONST is_cat_finite_obj_prod α I A  P π"

locale is_cat_finite_obj_coprod = is_cat_obj_coprod α I A  U π 
  for α I A  U π +
  assumes cat_fin_obj_coprod_index_in_ω: "I  ω" 

syntax "_is_cat_finite_obj_coprod" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ >CF..fin _ :/ _ ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "π : A >CF..fin U : I ↦↦Cα "  
  "CONST is_cat_finite_obj_coprod α I A  U π"

lemma (in is_cat_finite_obj_prod) cat_fin_obj_prod_index_vfinite: "vfinite I"
  using cat_fin_obj_prod_index_in_ω by auto

sublocale is_cat_finite_obj_prod  I: finite_category α :C I
  by (intro finite_categoryI')
    (
      auto
        simp: NTDom.HomDom.tiny_dg_category the_cat_discrete_components
        intro!: cat_fin_obj_prod_index_vfinite
    )

lemma (in is_cat_finite_obj_coprod) cat_fin_obj_coprod_index_vfinite:
  "vfinite I"
  using cat_fin_obj_coprod_index_in_ω by auto

sublocale is_cat_finite_obj_coprod  I: finite_category α :C I
  by (intro finite_categoryI')
    (
      auto 
        simp: NTDom.HomDom.tiny_dg_category the_cat_discrete_components 
        intro!: cat_fin_obj_coprod_index_vfinite
    )


text‹Rules.›

lemma (in is_cat_finite_obj_prod) 
  is_cat_finite_obj_prod_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "P' = P" and "A' = A" and "I' = I" and "ℭ' = " 
  shows "π : P' <CF..fin A' : I' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_finite_obj_prod_axioms)

mk_ide rf 
  is_cat_finite_obj_prod_def[unfolded is_cat_finite_obj_prod_axioms_def]
  |intro is_cat_finite_obj_prodI|
  |dest is_cat_finite_obj_prodD[dest]|
  |elim is_cat_finite_obj_prodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_finite_obj_prodD

lemma (in is_cat_finite_obj_coprod) 
  is_cat_finite_obj_coprod_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "U' = U" and "A' = A" and "I' = I" and "ℭ' = " 
  shows "π : A' >CF..fin U' : I' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_finite_obj_coprod_axioms)

mk_ide rf 
  is_cat_finite_obj_coprod_def[unfolded is_cat_finite_obj_coprod_axioms_def]
  |intro is_cat_finite_obj_coprodI|
  |dest is_cat_finite_obj_coprodD[dest]|
  |elim is_cat_finite_obj_coprodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_finite_obj_coprodD


text‹Duality.›

lemma (in is_cat_finite_obj_prod) is_cat_finite_obj_coprod_op:
  "op_ntcf π : A >CF..fin P : I ↦↦Cα op_cat "
  by (intro is_cat_finite_obj_coprodI)
    (
      cs_concl 
        cs_simp: cat_op_simps 
        cs_intro: cat_fin_obj_prod_index_in_ω cat_cs_intros cat_op_intros
    )

lemma (in is_cat_finite_obj_prod) is_cat_finite_obj_coprod_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf π : A >CF..fin P : I ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_finite_obj_coprod_op)

lemmas [cat_op_intros] = is_cat_finite_obj_prod.is_cat_finite_obj_coprod_op'

lemma (in is_cat_finite_obj_coprod) is_cat_finite_obj_prod_op:
  "op_ntcf π : U <CF..fin A : I ↦↦Cα op_cat "
  by (intro is_cat_finite_obj_prodI)
    (
      cs_concl 
        cs_simp: cat_op_simps 
        cs_intro: cat_fin_obj_coprod_index_in_ω cat_cs_intros cat_op_intros
    )

lemma (in is_cat_finite_obj_coprod) is_cat_finite_obj_prod_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf π : U <CF..fin A : I ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_finite_obj_prod_op)

lemmas [cat_op_intros] = is_cat_finite_obj_coprod.is_cat_finite_obj_prod_op'



subsection‹Product and coproduct of two objects›


subsubsection‹Definition and elementary properties›

locale is_cat_obj_prod_2 = is_cat_obj_prod α 2 ‹if2 a b  P π
  for α a b  P π

syntax "_is_cat_obj_prod_2" :: "V  V  V  V  V  V  bool"
  ((_ :/ _ <CF.× {_,_} :/ 2C ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "π : P <CF.× {a,b} : 2C ↦↦Cα "  
  "CONST is_cat_obj_prod_2 α a b  P π"

locale is_cat_obj_coprod_2 = is_cat_obj_coprod α 2 ‹if2 a b  P π
  for α a b  P π

syntax "_is_cat_obj_coprod_2" :: "V  V  V  V  V  V  bool"
  ((_ :/ {_,_} >CF. _ :/ 2C ↦↦Cı _) [51, 51, 51, 51, 51] 51)
translations "π : {a,b} >CF. U : 2C ↦↦Cα "  
  "CONST is_cat_obj_coprod_2 α a b  U π"

abbreviation proj_fst where "proj_fst π  vpfst (πNTMap)"
abbreviation proj_snd where "proj_snd π  vpsnd (πNTMap)"


text‹Rules.›

lemma (in is_cat_obj_prod_2) is_cat_obj_prod_2_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "P' = P" and "a' = a" and "b' = b" and "ℭ' = " 
  shows "π : P' <CF.× {a',b'} : 2C ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_obj_prod_2_axioms)

mk_ide rf is_cat_obj_prod_2_def
  |intro is_cat_obj_prod_2I|
  |dest is_cat_obj_prod_2D[dest]|
  |elim is_cat_obj_prod_2E[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_prod_2D

lemma (in is_cat_obj_coprod_2) is_cat_obj_coprod_2_axioms'[cat_lim_cs_intros]:
  assumes "α' = α" and "P' = P" and "a' = a" and "b' = b" and "ℭ' = " 
  shows "π : {a',b'} >CF. P' : 2C ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_obj_coprod_2_axioms)

mk_ide rf is_cat_obj_coprod_2_def
  |intro is_cat_obj_coprod_2I|
  |dest is_cat_obj_coprod_2D[dest]|
  |elim is_cat_obj_coprod_2E[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_coprod_2D


text‹Duality.›

lemma (in is_cat_obj_prod_2) is_cat_obj_coprod_2_op:
  "op_ntcf π : {a,b} >CF. P : 2C ↦↦Cα op_cat "
  by (rule is_cat_obj_coprod_2I[OF is_cat_obj_coprod_op])

lemma (in is_cat_obj_prod_2) is_cat_obj_coprod_2_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf π : {a,b} >CF. P : 2C ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_obj_coprod_2_op)

lemmas [cat_op_intros] = is_cat_obj_prod_2.is_cat_obj_coprod_2_op'

lemma (in is_cat_obj_coprod_2) is_cat_obj_prod_2_op:
  "op_ntcf π : P <CF.× {a,b} : 2C ↦↦Cα op_cat "
  by (rule is_cat_obj_prod_2I[OF is_cat_obj_prod_op])

lemma (in is_cat_obj_coprod_2) is_cat_obj_prod_2_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf π : P <CF.× {a,b} : 2C ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_obj_prod_2_op)

lemmas [cat_op_intros] = is_cat_obj_coprod_2.is_cat_obj_prod_2_op'


text‹Product/coproduct of two objects is a finite product/coproduct.›

sublocale is_cat_obj_prod_2  is_cat_finite_obj_prod α 2 ‹if2 a b  P π
proof(intro is_cat_finite_obj_prodI)
  show "2  ω" by simp
qed (cs_concl cs_simp: two[symmetric] cs_intro: cat_lim_cs_intros)

sublocale is_cat_obj_coprod_2  is_cat_finite_obj_coprod α 2 ‹if2 a b  P π
proof(intro is_cat_finite_obj_coprodI)
  show "2  ω" by simp
qed (cs_concl cs_simp: two[symmetric] cs_intro: cat_lim_cs_intros)


text‹Elementary properties.›

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_lr_in_Obj:
  shows cat_obj_prod_2_left_in_Obj[cat_lim_cs_intros]: "a  Obj" 
    and cat_obj_prod_2_right_in_Obj[cat_lim_cs_intros]: "b  Obj"
proof-
  have 0: "0  2" and 1: "1  2" by simp_all
  show "a  Obj" and "b  Obj"
    by 
      (
        intro 
          cf_discrete_selector_vrange[OF 0, simplified]
          cf_discrete_selector_vrange[OF 1, simplified]
      )+
qed

lemmas [cat_lim_cs_intros] = is_cat_obj_prod_2.cat_obj_prod_2_lr_in_Obj

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_lr_in_Obj:
  shows cat_obj_coprod_2_left_in_Obj[cat_lim_cs_intros]: "a  Obj" 
    and cat_obj_coprod_2_right_in_Obj[cat_lim_cs_intros]: "b  Obj"
  by 
    (
      intro is_cat_obj_prod_2.cat_obj_prod_2_lr_in_Obj[
        OF is_cat_obj_prod_2_op, unfolded cat_op_simps
        ]
    )+

lemmas [cat_lim_cs_intros] = is_cat_obj_coprod_2.cat_obj_coprod_2_lr_in_Obj


text‹Utilities/help lemmas.›

lemma helper_I2_proj_fst_proj_snd_iff: 
  "(j2. π'NTMapj = πNTMapj A f') 
    (proj_fst π' = proj_fst π A f'  proj_snd π' = proj_snd π A f')" 
  unfolding two by auto

lemma helper_I2_proj_fst_proj_snd_iff': 
  "(j2. π'NTMapj = f' A πNTMapj) 
    (proj_fst π' = f' A proj_fst π  proj_snd π' = f' A proj_snd π)" 
  unfolding two by auto


subsubsection‹Universal property›

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_unique_cone':
  assumes "π' : P' <CF.cone :→: (2) (if2 a b)  : :C (2) ↦↦Cα "
  shows
    "∃!f'. f' : P'  P 
      proj_fst π' = proj_fst π A f' 
      proj_snd π' = proj_snd π A f'"
  by 
    (
      rule cat_obj_prod_unique_cone'[
        OF assms, unfolded helper_I2_proj_fst_proj_snd_iff
        ]
    )

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_unique:
  assumes "π' : P' <CF.× {a,b} : 2C ↦↦Cα "
  shows "∃!f'. f' : P'  P  π' = π NTCF ntcf_const (:C (2))  f'"
  by (rule cat_obj_prod_unique[OF is_cat_obj_prod_2D[OF assms]])

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_unique':
  assumes "π' : P' <CF.× {a,b} : 2C ↦↦Cα "
  shows
    "∃!f'. f' : P'  P 
      proj_fst π' = proj_fst π A f' 
      proj_snd π' = proj_snd π A f'"
  by 
    (
      rule cat_obj_prod_unique'[
        OF is_cat_obj_prod_2D[OF assms], 
        unfolded helper_I2_proj_fst_proj_snd_iff
        ]
    )

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_unique_cocone':
  assumes "π' : :→: (2) (if2 a b)  >CF.cocone P' : :C (2) ↦↦Cα "
  shows
    "∃!f'. f' : P  P' 
      proj_fst π' = f' A proj_fst π 
      proj_snd π' = f' A proj_snd π"
  by 
    (
      rule cat_obj_coprod_unique_cocone'[
        OF assms, unfolded helper_I2_proj_fst_proj_snd_iff'
        ]
    )

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_unique:
  assumes "π' : {a,b} >CF. P' : 2C ↦↦Cα "
  shows "∃!f'. f' : P  P'  π' = ntcf_const (:C (2))  f' NTCF π"
  by (rule cat_obj_coprod_unique[OF is_cat_obj_coprod_2D[OF assms]])

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_unique':
  assumes "π' : {a,b} >CF. P' : 2C ↦↦Cα "
  shows
    "∃!f'. f' : P  P' 
      proj_fst π' = f' A proj_fst π 
      proj_snd π' = f' A proj_snd π"
  by 
    (
      rule cat_obj_coprod_unique'[
        OF is_cat_obj_coprod_2D[OF assms], 
        unfolded helper_I2_proj_fst_proj_snd_iff'
        ]
    )

lemma cat_obj_prod_2_ex_is_arr_isomorphism:
  assumes "π : P <CF.× {a,b} : 2C ↦↦Cα " 
    and "π' : P' <CF.× {a,b} : 2C ↦↦Cα "
  obtains f where "f : P' iso P" and "π' = π NTCF ntcf_const (:C (2))  f"
proof-
  interpret π: is_cat_obj_prod_2 α a b  P π by (rule assms(1))
  interpret π': is_cat_obj_prod_2 α a b  P' π' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_obj_prod_ex_is_arr_isomorphism[
          OF π.is_cat_obj_prod_axioms π'.is_cat_obj_prod_axioms
          ]
      )
qed

lemma cat_obj_coprod_2_ex_is_arr_isomorphism:
  assumes "π : {a,b} >CF. U : 2C ↦↦Cα " 
    and "π' : {a,b} >CF. U' : 2C ↦↦Cα "
  obtains f where "f : U iso U'" and "π' = ntcf_const (:C (2))  f NTCF π"
proof-
  interpret π: is_cat_obj_coprod_2 α a b  U π by (rule assms(1))
  interpret π': is_cat_obj_coprod_2 α a b  U' π' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_obj_coprod_ex_is_arr_isomorphism[
          OF π.is_cat_obj_coprod_axioms π'.is_cat_obj_coprod_axioms
          ]
      )
qed



subsection‹Pullbacks and pushouts›


subsubsection‹Definition and elementary properties›


text‹
The definitions and the elementary properties of the pullbacks and the 
pushouts can be found, for example, in Chapter III-3 and Chapter III-4 in 
\cite{mac_lane_categories_2010}. 
›

locale is_cat_pullback =
  is_cat_limit α →∙←C  𝔞𝔤𝔬𝔣𝔟CF X x + 
  cf_scospan α 𝔞 𝔤 𝔬 𝔣 𝔟 
  for α 𝔞 𝔤 𝔬 𝔣 𝔟  X x 

syntax "_is_cat_pullback" :: "V  V  V  V  V  V  V  V  V  bool"
  ((_ :/ _ <CF.pb _____ ↦↦Cı _) [51, 51, 51, 51, 51, 51, 51, 51] 51)
translations "x : X <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "  
  "CONST is_cat_pullback α 𝔞 𝔤 𝔬 𝔣 𝔟  X x"
                        
locale is_cat_pushout =
  is_cat_colimit α ←∙→C  𝔞𝔤𝔬𝔣𝔟CF X x +
  cf_sspan α 𝔞 𝔤 𝔬 𝔣 𝔟 
  for α 𝔞 𝔤 𝔬 𝔣 𝔟  X x

syntax "_is_cat_pushout" :: "V  V  V  V  V  V  V  V  V  bool"
  ((_ :/ _____ >CF.po _ ↦↦Cı _) [51, 51, 51, 51, 51, 51, 51, 51] 51)
translations "x : 𝔞𝔤𝔬𝔣𝔟 >CF.po X ↦↦Cα "  
  "CONST is_cat_pushout α 𝔞 𝔤 𝔬 𝔣 𝔟  X x"


text‹Rules.›

lemma (in is_cat_pullback) is_cat_pullback_axioms'[cat_lim_cs_intros]:
  assumes "α' = α"
    and "𝔞' = 𝔞"
    and "𝔤' = 𝔤"
    and "𝔬' = 𝔬"
    and "𝔣' = 𝔣"
    and "𝔟' = 𝔟"
    and "ℭ' = "
    and "X' = X"
  shows "x : X' <CF.pb 𝔞'𝔤'𝔬'𝔣'𝔟' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_pullback_axioms)

mk_ide rf is_cat_pullback_def
  |intro is_cat_pullbackI|
  |dest is_cat_pullbackD[dest]|
  |elim is_cat_pullbackE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_pullbackD

lemma (in is_cat_pushout) is_cat_pushout_axioms'[cat_lim_cs_intros]:
  assumes "α' = α"
    and "𝔞' = 𝔞"
    and "𝔤' = 𝔤"
    and "𝔬' = 𝔬"
    and "𝔣' = 𝔣"
    and "𝔟' = 𝔟"
    and "ℭ' = "
    and "X' = X"
  shows "x : 𝔞'𝔤'𝔬'𝔣'𝔟' >CF.po X' ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_pushout_axioms)

mk_ide rf is_cat_pushout_def
  |intro is_cat_pushoutI|
  |dest is_cat_pushoutD[dest]|
  |elim is_cat_pushoutE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_pushoutD


text‹Duality.›

lemma (in is_cat_pullback) is_cat_pushout_op:
  "op_ntcf x : 𝔞𝔤𝔬𝔣𝔟 >CF.po X ↦↦Cα op_cat "
  by (intro is_cat_pushoutI) 
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)+

lemma (in is_cat_pullback) is_cat_pushout_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf x : 𝔞𝔤𝔬𝔣𝔟 >CF.po X ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_pushout_op)

lemmas [cat_op_intros] = is_cat_pullback.is_cat_pushout_op'

lemma (in is_cat_pushout) is_cat_pullback_op:
  "op_ntcf x : X <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα op_cat "
  by (intro is_cat_pullbackI) 
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)+

lemma (in is_cat_pushout) is_cat_pullback_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf x : X <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_pullback_op)

lemmas [cat_op_intros] = is_cat_pushout.is_cat_pullback_op'


text‹Elementary properties.›

lemma cat_cone_cospan:
  assumes "x : X <CF.cone 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα "
    and "cf_scospan α 𝔞 𝔤 𝔬 𝔣 𝔟 "
  shows "xNTMap𝔬SS = 𝔤 A xNTMap𝔞SS"
    and "xNTMap𝔬SS = 𝔣 A xNTMap𝔟SS"
    and "𝔤 A xNTMap𝔞SS = 𝔣 A xNTMap𝔟SS"
proof-
  interpret x: is_cat_cone α X →∙←C  𝔞𝔤𝔬𝔣𝔟CF x 
    by (rule assms(1))
  interpret cospan: cf_scospan α 𝔞 𝔤 𝔬 𝔣 𝔟  by (rule assms(2))
  have 𝔤SS: "𝔤SS : 𝔞SS →∙←C 𝔬SS" and 𝔣SS: "𝔣SS : 𝔟SS →∙←C 𝔬SS" 
    by (cs_concl cs_simp: cs_intro: cat_ss_cs_intros)+
  from x.ntcf_Comp_commute[OF 𝔤SS] 𝔤SS 𝔣SS show
    "xNTMap𝔬SS = 𝔤 A xNTMap𝔞SS"
    by (cs_prems cs_simp: cat_ss_cs_simps cat_cs_simps cs_intro: cat_cs_intros)
  moreover from x.ntcf_Comp_commute[OF 𝔣SS] 𝔤SS 𝔣SS show 
    "xNTMap𝔬SS = 𝔣 A xNTMap𝔟SS"
    by (cs_prems cs_simp: cat_ss_cs_simps cat_cs_simps cs_intro: cat_cs_intros)
  ultimately show "𝔤 A xNTMap𝔞SS = 𝔣 A xNTMap𝔟SS" by simp
qed

lemma (in is_cat_pullback) cat_pb_cone_cospan:
  shows "xNTMap𝔬SS = 𝔤 A xNTMap𝔞SS"
    and "xNTMap𝔬SS = 𝔣 A xNTMap𝔟SS"
    and "𝔤 A xNTMap𝔞SS = 𝔣 A xNTMap𝔟SS"
  by (allrule cat_cone_cospan[OF is_cat_cone_axioms cf_scospan_axioms])

lemma cat_cocone_span:
  assumes "x : 𝔞𝔤𝔬𝔣𝔟CF >CF.cocone X : ←∙→C ↦↦Cα "
    and "cf_sspan α 𝔞 𝔤 𝔬 𝔣 𝔟 "
  shows "xNTMap𝔬SS = xNTMap𝔞SS A 𝔤"
    and "xNTMap𝔬SS = xNTMap𝔟SS A 𝔣"
    and "xNTMap𝔞SS A 𝔤 = xNTMap𝔟SS A 𝔣"
proof-
  interpret x: is_cat_cocone α X ←∙→C  𝔞𝔤𝔬𝔣𝔟CF x
    by (rule assms(1))
  interpret span: cf_sspan α 𝔞 𝔤 𝔬 𝔣 𝔟  by (rule assms(2))
  note op = 
    cat_cone_cospan
      [
        OF 
          x.is_cat_cone_op[unfolded cat_op_simps] 
          span.cf_scospan_op, 
          unfolded cat_op_simps
      ]
  from op(1) show "xNTMap𝔬SS = xNTMap𝔞SS A 𝔤"
    by 
      (
        cs_prems 
          cs_simp: cat_ss_cs_simps cat_op_simps 
          cs_intro: cat_cs_intros cat_ss_cs_intros
      )
  moreover from op(2) show "xNTMap𝔬SS = xNTMap𝔟SS A 𝔣"
    by 
      (
        cs_prems 
          cs_simp: cat_ss_cs_simps cat_op_simps 
          cs_intro: cat_cs_intros cat_ss_cs_intros
      )
  ultimately show "xNTMap𝔞SS A 𝔤 = xNTMap𝔟SS A 𝔣" by auto
qed

lemma (in is_cat_pushout) cat_po_cocone_span:
  shows "xNTMap𝔬SS = xNTMap𝔞SS A 𝔤"
    and "xNTMap𝔬SS = xNTMap𝔟SS A 𝔣"
    and "xNTMap𝔞SS A 𝔤 = xNTMap𝔟SS A 𝔣"
  by (allrule cat_cocone_span[OF is_cat_cocone_axioms cf_sspan_axioms])


subsubsection‹Universal property›

lemma is_cat_pullbackI':
  assumes "x : X <CF.cone 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα "
    and "cf_scospan α 𝔞 𝔤 𝔬 𝔣 𝔟 "
    and "x' X'.
      x' : X' <CF.cone 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα  
        ∃!f'.
          f' : X'  X 
          x'NTMap𝔞SS = xNTMap𝔞SS A f' 
          x'NTMap𝔟SS = xNTMap𝔟SS A f'"
  shows "x : X <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "
proof(intro is_cat_pullbackI is_cat_limitI')

  show "x : X <CF.cone 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα " 
    by (rule assms(1))
  interpret x: is_cat_cone α X →∙←C  𝔞𝔤𝔬𝔣𝔟CF x 
    by (rule assms(1))
  show "cf_scospan α 𝔞 𝔤 𝔬 𝔣 𝔟 " by (rule assms(2))
  interpret cospan: cf_scospan α 𝔞 𝔤 𝔬 𝔣 𝔟  by (rule assms(2))

  fix u' r' assume prems:
    "u' : r' <CF.cone 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα "

  interpret u': is_cat_cone α r' →∙←C  𝔞𝔤𝔬𝔣𝔟CF u' 
    by (rule prems)

  from assms(3)[OF prems] obtain f' 
    where f': "f' : r'  X"
      and u'_𝔞SS: "u'NTMap𝔞SS = xNTMap𝔞SS A f'"
      and u'_𝔟SS: "u'NTMap𝔟SS = xNTMap𝔟SS A f'"
      and unique_f': "f''.
        
          f'' : r'  X;
          u'NTMap𝔞SS = xNTMap𝔞SS A f'';
          u'NTMap𝔟SS = xNTMap𝔟SS A f''
          f'' = f'"
    by metis

  show "∃!f'. f' : r'  X  u' = x NTCF ntcf_const →∙←C  f'"
  proof(intro ex1I conjI; (elim conjE)?)

    show "u' = x NTCF ntcf_const →∙←C  f'"
    proof(rule ntcf_eqI)
      show "u' : cf_const →∙←C  r' CF 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα "
        by (rule u'.is_ntcf_axioms)
      from f' show 
        "x NTCF ntcf_const →∙←C  f' :
          cf_const →∙←C  r' CF 𝔞𝔤𝔬𝔣𝔟CF :
          →∙←C ↦↦Cα "
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      from f' have dom_rhs: 
        "𝒟 ((x NTCF ntcf_const →∙←C  f')NTMap) = →∙←CObj"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show "u'NTMap = (x NTCF ntcf_const →∙←C  f')NTMap"
      proof(rule vsv_eqI, unfold cat_cs_simps dom_rhs)
        fix a assume prems': "a  →∙←CObj"
        from this f' x.is_ntcf_axioms show
          "u'NTMapa = (x NTCF ntcf_const →∙←C  f')NTMapa"
          by (elim the_cat_scospan_ObjE; simp only:)
            (
              cs_concl
                cs_simp:
                  cat_cs_simps cat_ss_cs_simps 
                  u'_𝔟SS u'_𝔞SS 
                  cat_cone_cospan(1)[OF assms(1,2)] 
                  cat_cone_cospan(1)[OF prems assms(2)] 
                cs_intro: cat_cs_intros cat_ss_cs_intros
            )+
      qed (cs_concl cs_intro: cat_cs_intros | auto)+
    qed simp_all

    fix f'' assume prems: 
      "f'' : r'  X" "u' = x NTCF ntcf_const →∙←C  f''"
    have 𝔞SS: "𝔞SS  →∙←CObj" and 𝔟SS: "𝔟SS  →∙←CObj" 
      by (cs_concl cs_simp: cs_intro: cat_ss_cs_intros)+
    have "u'NTMapa = xNTMapa A f''" if "a  →∙←CObj" for a
    proof-
      from prems(2) have 
        "u'NTMapa = (x NTCF ntcf_const →∙←C  f'')NTMapa"
        by simp
      from this that prems(1) show "u'NTMapa = xNTMapa A f''"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    qed
    from unique_f'[OF prems(1) this[OF 𝔞SS] this[OF 𝔟SS]] show "f'' = f'".

  qed (intro f')

qed

lemma is_cat_pushoutI':
  assumes "x : 𝔞𝔤𝔬𝔣𝔟CF >CF.cocone X : ←∙→C ↦↦Cα "
    and "cf_sspan α 𝔞 𝔤 𝔬 𝔣 𝔟 "
    and "x' X'. x' : 𝔞𝔤𝔬𝔣𝔟CF >CF.cocone X' : ←∙→C ↦↦Cα  
      ∃!f'.
        f' : X  X' 
        x'NTMap𝔞SS = f' A xNTMap𝔞SS 
        x'NTMap𝔟SS = f' A xNTMap𝔟SS"
  shows "x : 𝔞𝔤𝔬𝔣𝔟 >CF.po X ↦↦Cα "
proof-
  interpret x: is_cat_cocone α X ←∙→C  𝔞𝔤𝔬𝔣𝔟CF x 
    by (rule assms(1))
  interpret span: cf_sspan α 𝔞 𝔤 𝔬 𝔣 𝔟  by (rule assms(2))
  have assms_3': 
    "∃!f'.
      f' : X  X' 
      x'NTMap𝔞SS = xNTMap𝔞SS Aop_cat  f' 
      x'NTMap𝔟SS = xNTMap𝔟SS Aop_cat  f'"
    if "x' : X' <CF.cone 𝔞𝔤𝔬𝔣𝔟CFop_cat  : →∙←C ↦↦Cα op_cat "
    for x' X'
  proof-
    from that(1) have [cat_op_simps]:
      "f' : X  X'  
      x'NTMap𝔞SS = xNTMap𝔞SS Aop_cat  f' 
      x'NTMap𝔟SS = xNTMap𝔟SS Aop_cat  f' 
        f' : X  X' 
        x'NTMap𝔞SS = f' A xNTMap𝔞SS 
        x'NTMap𝔟SS = f' A xNTMap𝔟SS" 
      for f'
      by (intro iffI conjI; (elim conjE)?)
        (
          cs_concl 
            cs_simp: category.op_cat_Comp[symmetric] cat_op_simps cat_cs_simps 
            cs_intro: cat_cs_intros cat_ss_cs_intros
        )+
    interpret x': 
      is_cat_cone α X' →∙←C ‹op_cat  𝔞𝔤𝔬𝔣𝔟CFop_cat  x'
      by (rule that)
    show ?thesis
      unfolding cat_op_simps
      by 
        (
          rule assms(3)[
            OF x'.is_cat_cocone_op[unfolded cat_op_simps], 
            unfolded cat_op_simps
            ]
        )
  qed
  interpret op_x: is_cat_pullback α 𝔞 𝔤 𝔬 𝔣 𝔟 ‹op_cat  X ‹op_ntcf x 
    using 
      is_cat_pullbackI'
        [
          OF x.is_cat_cone_op[unfolded cat_op_simps] 
          span.cf_scospan_op, 
          unfolded cat_op_simps, 
          OF assms_3'
        ]
    by simp
  show "x : 𝔞𝔤𝔬𝔣𝔟 >CF.po X ↦↦Cα "
    by (rule op_x.is_cat_pushout_op[unfolded cat_op_simps])
qed
                   
lemma (in is_cat_pullback) cat_pb_unique_cone:
  assumes "x' : X' <CF.cone 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα "
  shows "∃!f'.
    f' : X'  X 
    x'NTMap𝔞SS = xNTMap𝔞SS A f' 
    x'NTMap𝔟SS = xNTMap𝔟SS A f'"
proof-
  interpret x': is_cat_cone α X' →∙←C  𝔞𝔤𝔬𝔣𝔟CF x' 
    by (rule assms)
  from cat_lim_unique_cone[OF assms] obtain f'
    where f': "f' : X'  X" 
      and x'_def: "x' = x NTCF ntcf_const →∙←C  f'"
      and unique_f': "f''.
         f'' : X'  X; x' = x NTCF ntcf_const →∙←C  f''  
        f'' = f'"
    by auto
  have 𝔞SS: "𝔞SS  →∙←CObj" and 𝔟SS: "𝔟SS  →∙←CObj"
    by (cs_concl cs_intro: cat_ss_cs_intros)+
  show ?thesis
  proof(intro ex1I conjI; (elim conjE)?)
    show "f' : X'  X" by (rule f')
    have "x'NTMapa = xNTMapa A f'" if "a  →∙←CObj" for a
    proof-
      from x'_def have 
        "x'NTMapa = (x NTCF ntcf_const →∙←C  f')NTMapa"
        by simp
      from this that f' show "x'NTMapa = xNTMapa A f'"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    qed
    from this[OF 𝔞SS] this[OF 𝔟SS] show 
      "x'NTMap𝔞SS = xNTMap𝔞SS A f'"
      "x'NTMap𝔟SS = xNTMap𝔟SS A f'"
      by auto
    fix f'' assume prems': 
      "f'' : X'  X"
      "x'NTMap𝔞SS = xNTMap𝔞SS A f''"
      "x'NTMap𝔟SS = xNTMap𝔟SS A f''"
    have "x' = x NTCF ntcf_const →∙←C  f''"
    proof(rule ntcf_eqI)
      show "x' : cf_const →∙←C  X' CF 𝔞𝔤𝔬𝔣𝔟CF : →∙←C ↦↦Cα "
        by (rule x'.is_ntcf_axioms)
      from prems'(1) show
        "x NTCF ntcf_const →∙←C  f'' :
          cf_const →∙←C  X' CF 𝔞𝔤𝔬𝔣𝔟CF :
          →∙←C ↦↦Cα "
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      have dom_lhs: "𝒟 (x'NTMap) = →∙←CObj" 
        by (cs_concl cs_simp: cat_cs_simps)
      from prems'(1) have dom_rhs:
        "𝒟 ((x NTCF ntcf_const →∙←C  f'')NTMap) = →∙←CObj"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show "x'NTMap = (x NTCF ntcf_const →∙←C  f'')NTMap"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
        fix a assume prems'': "a  →∙←CObj"
        from this prems'(1) show 
          "x'NTMapa = (x NTCF ntcf_const →∙←C  f'')NTMapa"
          by (elim the_cat_scospan_ObjE; simp only:)
            (
              cs_concl 
                cs_simp: 
                  prems'(2,3)
                  cat_cone_cospan(1,2)[OF assms cf_scospan_axioms] 
                  cat_pb_cone_cospan 
                  cat_ss_cs_simps cat_cs_simps 
                cs_intro: cat_ss_cs_intros cat_cs_intros
            )+
      qed (auto simp: cat_cs_intros)
    qed simp_all
    from unique_f'[OF prems'(1) this] show "f'' = f'".
  qed
qed

lemma (in is_cat_pullback) cat_pb_unique:
  assumes "x' : X' <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "
  shows "∃!f'. f' : X'  X  x' = x NTCF ntcf_const →∙←C  f'"
  by (rule cat_lim_unique[OF is_cat_pullbackD(1)[OF assms]])

lemma (in is_cat_pullback) cat_pb_unique':
  assumes "x' : X' <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "
  shows "∃!f'.
    f' : X'  X 
    x'NTMap𝔞SS = xNTMap𝔞SS A f' 
    x'NTMap𝔟SS = xNTMap𝔟SS A f'"
proof-
  interpret x': is_cat_pullback α 𝔞 𝔤 𝔬 𝔣 𝔟  X' x' by (rule assms(1))
  show ?thesis by (rule cat_pb_unique_cone[OF x'.is_cat_cone_axioms])
qed

lemma (in is_cat_pushout) cat_po_unique_cocone:
  assumes "x' : 𝔞𝔤𝔬𝔣𝔟CF >CF.cocone X' : ←∙→C ↦↦Cα "
  shows "∃!f'.
    f' : X  X' 
    x'NTMap𝔞SS = f' A xNTMap𝔞SS 
    x'NTMap𝔟SS = f' A xNTMap𝔟SS"
proof-
  interpret x': is_cat_cocone α X' ←∙→C  𝔞𝔤𝔬𝔣𝔟CF x'
    by (rule assms(1))
  have [cat_op_simps]:
    "f' : X  X' 
    x'NTMap𝔞SS = xNTMap𝔞SS Aop_cat  f' 
    x'NTMap𝔟SS = xNTMap𝔟SS Aop_cat  f' 
      f' : X  X' 
      x'NTMap𝔞SS = f' A xNTMap𝔞SS 
      x'NTMap𝔟SS = f' A xNTMap𝔟SS" 
    for f'
    by (intro iffI conjI; (elim conjE)?)
      (
        cs_concl 
          cs_simp: category.op_cat_Comp[symmetric] cat_op_simps cat_cs_simps  
          cs_intro: cat_cs_intros cat_ss_cs_intros
      )+
  show ?thesis
    by 
      (
        rule is_cat_pullback.cat_pb_unique_cone[
          OF is_cat_pullback_op x'.is_cat_cone_op[unfolded cat_op_simps], 
          unfolded cat_op_simps
          ]
     )
qed

lemma (in is_cat_pushout) cat_po_unique:
  assumes "x' : 𝔞𝔤𝔬𝔣𝔟 >CF.po X' ↦↦Cα "
  shows "∃!f'. f' : X  X'  x' = ntcf_const ←∙→C  f' NTCF x"
  by (rule cat_colim_unique[OF is_cat_pushoutD(1)[OF assms]])

lemma (in is_cat_pushout) cat_po_unique':
  assumes "x' : 𝔞𝔤𝔬𝔣𝔟 >CF.po X' ↦↦Cα "
  shows "∃!f'.
    f' : X  X' 
    x'NTMap𝔞SS = f' A xNTMap𝔞SS 
    x'NTMap𝔟SS = f' A xNTMap𝔟SS"
proof-
  interpret x': is_cat_pushout α 𝔞 𝔤 𝔬 𝔣 𝔟  X' x' by (rule assms(1))
  show ?thesis by (rule cat_po_unique_cocone[OF x'.is_cat_cocone_axioms])
qed

lemma cat_pullback_ex_is_arr_isomorphism:
  assumes "x : X <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "
    and "x' : X' <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "
  obtains f where "f : X' iso X" 
    and "x' = x NTCF ntcf_const →∙←C   f"
proof-
  interpret x: is_cat_pullback α 𝔞 𝔤 𝔬 𝔣 𝔟  X x by (rule assms(1))
  interpret x': is_cat_pullback α 𝔞 𝔤 𝔬 𝔣 𝔟  X' x' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_lim_ex_is_arr_isomorphism[
          OF x.is_cat_limit_axioms x'.is_cat_limit_axioms
          ]
      )
qed

lemma cat_pullback_ex_is_arr_isomorphism':
  assumes "x : X <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "
    and "x' : X' <CF.pb 𝔞𝔤𝔬𝔣𝔟 ↦↦Cα "
  obtains f where "f : X' iso X" 
    and "x'NTMap𝔞SS = xNTMap𝔞SS A f"
    and "x'NTMap𝔟SS = xNTMap𝔟SS A f"
proof-
  interpret x: is_cat_pullback α 𝔞 𝔤 𝔬 𝔣 𝔟  X x by (rule assms(1))
  interpret x': is_cat_pullback α 𝔞 𝔤 𝔬 𝔣 𝔟  X' x' by (rule assms(2))
  obtain f where f: "f : X' iso X"
    and "j  →∙←CObj  x'NTMapj = xNTMapj A f" for j
    by 
      (
        elim cat_lim_ex_is_arr_isomorphism'[
          OF x.is_cat_limit_axioms x'.is_cat_limit_axioms
          ]
      )
  then have 
    "x'NTMap𝔞SS = xNTMap𝔞SS A f" 
    "x'NTMap𝔟SS = xNTMap𝔟SS A f"
    by (auto simp: cat_ss_cs_intros)
  with f show ?thesis using that by simp
qed

lemma cat_pushout_ex_is_arr_isomorphism:
  assumes "x : 𝔞𝔤𝔬𝔣𝔟 >CF.po X ↦↦Cα "
    and "x' : 𝔞𝔤𝔬𝔣𝔟 >CF.po X' ↦↦Cα "
  obtains f where "f : X iso X'" 
    and "x' = ntcf_const ←∙→C  f NTCF x"
proof-
  interpret x: is_cat_pushout α 𝔞 𝔤 𝔬 𝔣 𝔟  X x by (rule assms(1))
  interpret x': is_cat_pushout α 𝔞 𝔤 𝔬 𝔣 𝔟  X' x' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_colim_ex_is_arr_isomorphism[
          OF x.is_cat_colimit_axioms x'.is_cat_colimit_axioms
          ]
      )
qed

lemma cat_pushout_ex_is_arr_isomorphism':
  assumes "x : 𝔞𝔤𝔬𝔣𝔟 >CF.po X ↦↦Cα "
    and "x' : 𝔞𝔤𝔬𝔣𝔟 >CF.po X' ↦↦Cα "
  obtains f where "f : X iso X'" 
    and "x'NTMap𝔞SS = f A xNTMap𝔞SS"
    and "x'NTMap𝔟SS = f A xNTMap𝔟SS"
proof-
  interpret x: is_cat_pushout α 𝔞 𝔤 𝔬 𝔣 𝔟  X x by (rule assms(1))
  interpret x': is_cat_pushout α 𝔞 𝔤 𝔬 𝔣 𝔟  X' x' by (rule assms(2))
  obtain f where f: "f : X iso X'"
    and "j  ←∙→CObj  x'NTMapj = f A xNTMapj" for j
    by 
      (
        elim cat_colim_ex_is_arr_isomorphism'[
          OF x.is_cat_colimit_axioms x'.is_cat_colimit_axioms,
          unfolded the_cat_parallel_components(1)
          ]
      )
  then have "x'NTMap𝔞SS = f A xNTMap𝔞SS"
    and "x'NTMap𝔟SS = f A xNTMap𝔟SS"
    by (auto simp: cat_ss_cs_intros)
  with f show ?thesis using that by simp
qed



subsection‹Equalizers and coequalizers›


subsubsection‹Definition and elementary properties›


text‹
See \cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Equaliser_(mathematics)}
}.
›

locale is_cat_equalizer =
  is_cat_limit α ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL  ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 E ε 
  for α 𝔞 𝔟 𝔤 𝔣  E ε +
  assumes cat_eq_𝔤[cat_lim_cs_intros]: "𝔤 : 𝔞  𝔟"
    and cat_eq_𝔣[cat_lim_cs_intros]: "𝔣 : 𝔞  𝔟"

syntax "_is_cat_equalizer" :: "V  V  V  V  V  V  V  V  bool"
  ((_ :/ _ <CF.eq '(_,_,_,_') :/ ↑↑2C ↦↦Cı _) [51, 51, 51, 51, 51, 51] 51)
translations "ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "  
  "CONST is_cat_equalizer α 𝔞 𝔟 𝔤 𝔣  E ε"

locale is_cat_coequalizer =
  is_cat_colimit α ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL  ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 E ε 
  for α 𝔞 𝔟 𝔤 𝔣  E ε +
  assumes cat_coeq_𝔤[cat_lim_cs_intros]: "𝔤 : 𝔟  𝔞"
    and cat_coeq_𝔣[cat_lim_cs_intros]: "𝔣 : 𝔟  𝔞"

syntax "_is_cat_coequalizer" :: "V  V  V  V  V  V  V  V  bool"
  ((_ :/ '(_,_,_,_') >CF.coeq _ :/ ↑↑2C ↦↦Cı _) [51, 51, 51, 51, 51, 51] 51)
translations "ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "  
  "CONST is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E ε"


text‹Rules.›

lemma (in is_cat_equalizer) is_cat_equalizer_axioms'[cat_lim_cs_intros]:
  assumes "α' = α"
    and "E' = E"
    and "𝔞' = 𝔞"
    and "𝔟' = 𝔟"
    and "𝔤' = 𝔤"
    and "𝔣' = 𝔣"
    and "ℭ' = "
  shows "ε : E' <CF.eq (𝔞',𝔟',𝔤',𝔣') : ↑↑2C ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_equalizer_axioms)

mk_ide rf is_cat_equalizer_def[unfolded is_cat_equalizer_axioms_def]
  |intro is_cat_equalizerI|
  |dest is_cat_equalizerD[dest]|
  |elim is_cat_equalizerE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_equalizerD(1)

lemma (in is_cat_coequalizer) is_cat_coequalizer_axioms'[cat_lim_cs_intros]:
  assumes "α' = α"
    and "E' = E"
    and "𝔞' = 𝔞"
    and "𝔟' = 𝔟"
    and "𝔤' = 𝔤"
    and "𝔣' = 𝔣"
    and "ℭ' = "
  shows "ε : (𝔞',𝔟',𝔤',𝔣') >CF.coeq E' : ↑↑2C ↦↦Cα' ℭ'"
  unfolding assms by (rule is_cat_coequalizer_axioms)

mk_ide rf is_cat_coequalizer_def[unfolded is_cat_coequalizer_axioms_def]
  |intro is_cat_coequalizerI|
  |dest is_cat_coequalizerD[dest]|
  |elim is_cat_coequalizerE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_coequalizerD(1)


text‹Elementary properties.›

sublocale is_cat_equalizer  cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣  
  by (intro cf_parallelI cat_parallelI)
    (simp_all add: cat_parallel_cs_intros cat_lim_cs_intros cat_cs_intros)

sublocale is_cat_coequalizer  cf_parallel α 𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 
  by (intro cf_parallelI cat_parallelI)
    (
      simp_all add: 
        cat_parallel_cs_intros cat_lim_cs_intros cat_cs_intros 
        cat_PL_ineq[symmetric]
    )


text‹Duality.›

lemma (in is_cat_equalizer) is_cat_coequalizer_op:
  "op_ntcf ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα op_cat "
  by (intro is_cat_coequalizerI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros cat_lim_cs_intros)+

lemma (in is_cat_equalizer) is_cat_coequalizer_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_coequalizer_op)

lemmas [cat_op_intros] = is_cat_equalizer.is_cat_coequalizer_op'

lemma (in is_cat_coequalizer) is_cat_equalizer_op:
  "op_ntcf ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα op_cat "
  by (intro is_cat_equalizerI)
    (
      cs_concl
        cs_simp: cat_op_simps
        cs_intro: cat_cs_intros cat_op_intros cat_lim_cs_intros
    )+

lemma (in is_cat_coequalizer) is_cat_equalizer_op'[cat_op_intros]:
  assumes "ℭ' = op_cat "
  shows "op_ntcf ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα ℭ'"
  unfolding assms by (rule is_cat_equalizer_op)

lemmas [cat_op_intros] = is_cat_coequalizer.is_cat_equalizer_op'


text‹Elementary properties.›

lemma cf_parallel_if_is_cat_cone:
  assumes "ε :
    E <CF.cone ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα "
    and "𝔤 : 𝔞  𝔟"
    and "𝔣 : 𝔞  𝔟"
  shows "cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 "
proof-
  let ?II = ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL and ?II_II = ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣
  interpret is_cat_cone α E ?II  ?II_II ε by (rule assms(1))
  show ?thesis
    by (intro cf_parallelI cat_parallelI)
      (
        simp_all add: 
          assms cat_parallel_cs_intros cat_lim_cs_intros cat_cs_intros
      )
qed

lemma cf_parallel_if_is_cat_cocone:
  assumes "ε' :
    ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 >CF.cocone E' : ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL ↦↦Cα "
    and "𝔤 : 𝔟  𝔞"
    and "𝔣 : 𝔟  𝔞"
  shows "cf_parallel α 𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 "
proof-
  let ?II = ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL and ?II_II = ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤
  interpret is_cat_cocone α E' ?II  ?II_II ε' by (rule assms(1))
  show ?thesis
    by (intro cf_parallelI cat_parallelI)
      (
        simp_all add: 
          assms 
          cat_parallel_cs_intros 
          cat_lim_cs_intros 
          cat_cs_intros
          cat_PL_ineq[symmetric]
      )
qed

lemma (in category) cat_cf_parallel_cat_equalizer: 
  assumes "𝔤 : 𝔞  𝔟" and "𝔣 : 𝔞  𝔟"
  shows "cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 "
  using assms 
  by (intro cf_parallelI cat_parallelI)
    (auto simp: cat_parallel_cs_intros cat_cs_intros)

lemma (in category) cat_cf_parallel_cat_coequalizer: 
  assumes "𝔤 : 𝔟  𝔞" and "𝔣 : 𝔟  𝔞"
  shows "cf_parallel α 𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 "
  using assms 
  by (intro cf_parallelI cat_parallelI)
    (simp_all add: cat_parallel_cs_intros cat_cs_intros cat_PL_ineq[symmetric])

lemma cat_cone_cf_par_eps_NTMap_app:
  assumes "ε :
    E <CF.cone ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα "
    and "𝔤 : 𝔞  𝔟" 
    and "𝔣 : 𝔞  𝔟"
  shows 
    "εNTMap𝔟PL = 𝔤 A εNTMap𝔞PL" 
    "εNTMap𝔟PL = 𝔣 A εNTMap𝔞PL"
proof-
  let ?II = ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL and ?II_II = ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣
  interpret ε: is_cat_cone α E ?II  ?II_II ε by (rule assms(1))
  from assms(2,3) have 𝔞: "𝔞  Obj" and 𝔟: "𝔟  Obj" by auto
  interpret par: cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣  
    by (intro cf_parallel_if_is_cat_cone, rule assms) (auto intro: assms 𝔞 𝔟)
  have 𝔤PL: "𝔤PL : 𝔞PL ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔟PL" 
    and 𝔣PL: "𝔣PL : 𝔞PL ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔟PL"
    by 
      (
        simp_all add: 
          par.the_cat_parallel_is_arr_𝔞𝔟𝔤 par.the_cat_parallel_is_arr_𝔞𝔟𝔣
      )
  from ε.ntcf_Comp_commute[OF 𝔤PL] show "εNTMap𝔟PL = 𝔤 A εNTMap𝔞PL"
    by (*slow*)
      (
        cs_prems 
          cs_simp: cat_parallel_cs_simps cat_cs_simps 
          cs_intro: cat_cs_intros cat_parallel_cs_intros 
      )
  from ε.ntcf_Comp_commute[OF 𝔣PL] show "εNTMap𝔟PL = 𝔣 A εNTMap𝔞PL"
    by (*slow*)
      (
        cs_prems 
          cs_simp: cat_parallel_cs_simps cat_cs_simps 
          cs_intro: cat_cs_intros cat_parallel_cs_intros 
      )
qed

lemma cat_cocone_cf_par_eps_NTMap_app:
  assumes "ε :
    ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 >CF.cocone E : ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL ↦↦Cα "
    and "𝔤 : 𝔟  𝔞" 
    and "𝔣 : 𝔟  𝔞"
  shows 
    "εNTMap𝔟PL = εNTMap𝔞PL A 𝔤" 
    "εNTMap𝔟PL = εNTMap𝔞PL A 𝔣"    
proof-
  let ?II = ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL and ?II_II = ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤
  interpret ε: is_cat_cocone α E ?II  ?II_II ε by (rule assms(1))
  from assms(2,3) have 𝔞: "𝔞  Obj" and 𝔟: "𝔟  Obj" by auto
  interpret par: cf_parallel α 𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤  
    by (intro cf_parallel_if_is_cat_cocone, rule assms) (auto intro: assms 𝔞 𝔟)
  note ε_NTMap_app = 
    cat_cone_cf_par_eps_NTMap_app[
      OF ε.is_cat_cone_op[unfolded cat_op_simps],
      unfolded cat_op_simps,  
      OF assms(2,3)
      ]
  from ε_NTMap_app show ε_NTMap_app:
    "εNTMap𝔟PL = εNTMap𝔞PL A 𝔤"
    "εNTMap𝔟PL = εNTMap𝔞PL A 𝔣"
    by 
      (
        cs_concl
          cs_simp: cat_parallel_cs_simps category.op_cat_Comp[symmetric] 
          cs_intro: cat_cs_intros cat_parallel_cs_intros
      )+
qed

lemma (in is_cat_equalizer) cat_eq_2_eps_NTMap_app:
  "εNTMap𝔟PL = 𝔤 A εNTMap𝔞PL" 
  "εNTMap𝔟PL = 𝔣 A εNTMap𝔞PL"
  by 
    (
      intro cat_cone_cf_par_eps_NTMap_app[
        OF is_cat_cone_axioms cat_eq_𝔤 cat_eq_𝔣
        ]
    )+

lemma (in is_cat_coequalizer) cat_coeq_2_eps_NTMap_app:
  "εNTMap𝔟PL = εNTMap𝔞PL A 𝔤" 
  "εNTMap𝔟PL = εNTMap𝔞PL A 𝔣"
  by 
    (
      intro cat_cocone_cf_par_eps_NTMap_app[
        OF is_cat_cocone_axioms cat_coeq_𝔤 cat_coeq_𝔣
        ]
    )+

lemma (in is_cat_equalizer) cat_eq_Comp_eq: 
  "𝔤 A εNTMap𝔞PL = 𝔣 A εNTMap𝔞PL"
  "𝔣 A εNTMap𝔞PL = 𝔤 A εNTMap𝔞PL"
  unfolding cat_eq_2_eps_NTMap_app[symmetric] by simp_all

lemma (in is_cat_coequalizer) cat_coeq_Comp_eq: 
  "εNTMap𝔞PL A 𝔤 = εNTMap𝔞PL A 𝔣"
  "εNTMap𝔞PL A 𝔣 = εNTMap𝔞PL A 𝔤"
  unfolding cat_coeq_2_eps_NTMap_app[symmetric] by simp_all


subsubsection‹Universal property›

lemma is_cat_equalizerI':
  assumes "ε :
    E <CF.cone ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα "
    and "𝔤 : 𝔞  𝔟"
    and "𝔣 : 𝔞  𝔟"
    and "ε' E'. ε' :
      E' <CF.cone ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 : 
      ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα  
      ∃!f'. f' : E'  E  ε'NTMap𝔞PL = εNTMap𝔞PL A f'"
  shows "ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "
proof-
  let ?II = ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL and ?II_II = ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣
  interpret ε: is_cat_cone α E ?II  ?II_II ε by (rule assms(1))
  interpret: cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 
    by (rule ε.NTDom.HomCod.cat_cf_parallel_cat_equalizer[OF assms(2,3)])
  show ?thesis
  proof(intro is_cat_equalizerI is_cat_limitI' assms(1-3))
    fix u' r' assume prems: "u' : r' <CF.cone ?II_II : ?II ↦↦Cα "
    interpret u': is_cat_cone α r' ?II  ?II_II u' by (rule prems)
    from assms(4)[OF prems] obtain f'
      where f': "f' : r'  E"
        and u'_NTMap_app_𝔞: "u'NTMap𝔞PL = εNTMap𝔞PL A f'"
        and unique_f': 
          "f''.
            
              f'' : r'  E; 
              u'NTMap𝔞PL = εNTMap𝔞PL A f''
              f'' = f'"
      by metis
    show "∃!f'. f' : r'  E  u' = ε NTCF ntcf_const ?II  f'"
    proof(intro ex1I conjI; (elim conjE)?)
      show "u' = ε NTCF ntcf_const ?II  f'"
      proof(rule ntcf_eqI)
        show "u' : cf_const ?II  r' CF ?II_II : ?II ↦↦Cα "
          by (rule u'.is_ntcf_axioms)
        from f' show "ε NTCF ntcf_const ?II  f' :
          cf_const ?II  r' CF ?II_II : ?II ↦↦Cα "
          by 
            (
              cs_concl 
                cs_simp: cat_cs_simps cat_ss_cs_simps 
                cs_intro: cat_cs_intros cat_ss_cs_intros
            )
        have dom_lhs: "𝒟 (u'NTMap) = ?IIObj"
          unfolding cat_cs_simps by simp
        from f' have dom_rhs:
          "𝒟 ((ε NTCF ntcf_const ?II  f')NTMap) = ?IIObj"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        show "u'NTMap = (ε NTCF ntcf_const ?II  f')NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix a assume prems': "a  ?IIObj"
          note [cat_parallel_cs_simps] = 
            cat_cone_cf_par_eps_NTMap_app[OF u'.is_cat_cone_axioms assms(2-3)]
            cat_cone_cf_par_eps_NTMap_app[OF assms(1-3)]
            u'_NTMap_app_𝔞
          from prems' f' assms(2,3) show 
            "u'NTMapa = (ε NTCF ntcf_const ?II  f')NTMapa"
            by (elim the_cat_parallel_ObjE; simp only:)
              (
                cs_concl 
                  cs_simp: cat_parallel_cs_simps cat_cs_simps
                  cs_intro: cat_cs_intros cat_parallel_cs_intros
              )
        qed (cs_concl cs_intro: V_cs_intros cat_cs_intros)+
      qed simp_all
      fix f'' assume prems'': 
        "f'' : r'  E" "u' = ε NTCF ntcf_const ?II  f''"
      from prems''(2) have u'_NTMap_a:
        "u'NTMapa = (ε NTCF ntcf_const ?II  f'')NTMapa"
        for a 
        by simp
      have "u'NTMap𝔞PL = εNTMap𝔞PL A f''"  
        using u'_NTMap_a[of 𝔞PL] prems''(1) 
        by 
          (
            cs_prems 
              cs_simp: cat_parallel_cs_simps cat_cs_simps 
              cs_intro: cat_parallel_cs_intros cat_cs_intros
          )
      from unique_f'[OF prems''(1) this] show "f'' = f'".
    qed (rule f')
  qed
qed

lemma is_cat_coequalizerI':
  assumes "ε :
    ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 >CF.cocone E : 
    ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL ↦↦Cα "
    and "𝔤 : 𝔟  𝔞"
    and "𝔣 : 𝔟  𝔞"
    and "ε' E'. ε' :
      ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 >CF.cocone E' : 
      ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL ↦↦Cα  
      ∃!f'. f' : E  E'  ε'NTMap𝔞PL = f' A εNTMap𝔞PL"
  shows "ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "
proof-
  let ?op_II = ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL 
    and ?op_II_II = ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤
    and ?II = ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL
    and ?II_II = ↑↑→↑↑ (op_cat ) 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣
  interpret ε: is_cat_cocone α E ?op_II  ?op_II_II ε by (rule assms(1))
  interpret par: cf_parallel α 𝔟PL 𝔞PL 𝔣PL  𝔤PL 𝔟 𝔞 𝔣 𝔤 
    by (rule ε.NTDom.HomCod.cat_cf_parallel_cat_coequalizer[OF assms(2,3)])
  interpret op_par: cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 ‹op_cat 
    by (rule par.cf_parallel_op)
  have assms_4': 
    "∃!f'. f' : E  E'  ε'NTMap𝔞PL = εNTMap𝔞PL Aop_cat  f'"
    if "ε' : E' <CF.cone ?II_II : ?II ↦↦Cα op_cat " for ε' E'
  proof-
    have [cat_op_simps]:
      "f' : E  E'  ε'NTMap𝔞PL = εNTMap𝔞PL Aop_cat  f' 
        f' : E  E'  ε'NTMap𝔞PL = f' A εNTMap𝔞PL"
      for f'
      by (intro iffI conjI; (elim conjE)?)
        (
          cs_concl 
            cs_simp: category.op_cat_Comp[symmetric] cat_op_simps cat_cs_simps 
            cs_intro: cat_cs_intros cat_parallel_cs_intros
        )+
    interpret ε': is_cat_cone α E' ?II ‹op_cat  ?II_II ε' by (rule that)
    show ?thesis
      unfolding cat_op_simps
      by 
        (
          rule assms(4)[
            OF ε'.is_cat_cocone_op[unfolded cat_op_simps], 
            unfolded cat_op_simps
            ]
        )
  qed
  interpret op_ε: is_cat_equalizer α 𝔞 𝔟 𝔤 𝔣 ‹op_cat  E ‹op_ntcf ε 
    by 
      (
        rule 
          is_cat_equalizerI'
            [
              OF ε.is_cat_cone_op[unfolded cat_op_simps], 
              unfolded cat_op_simps, 
              OF assms(2,3) assms_4'
            ]
      )
  show ?thesis by (rule op_ε.is_cat_coequalizer_op[unfolded cat_op_simps])
qed

lemma (in is_cat_equalizer) cat_eq_unique_cone:
  assumes "ε' :
    E' <CF.cone ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα "
    (is ε' : E' <CF.cone ?II_II : ?II ↦↦Cα )
  shows "∃!f'. f' : E'  E  ε'NTMap𝔞PL = εNTMap𝔞PL A f'"
proof-
  interpret ε': is_cat_cone α E' ?II  ?II_II ε' by (rule assms(1))
  from cat_lim_unique_cone[OF assms(1)] obtain f' where f': "f' : E'  E"
    and ε'_def: "ε' = ε NTCF ntcf_const ?II  f'"
    and unique: 
      " f'' : E'  E; ε' = ε NTCF ntcf_const ?II  f''   f'' = f'" 
    for f''
    by auto
  show ?thesis
  proof(intro ex1I conjI; (elim conjE)?)
    show f': "f' : E'  E" by (rule f')
    from ε'_def have "ε'NTMap𝔞PL = (ε NTCF ntcf_const ?II  f')NTMap𝔞PL"
      by simp
    from this f' show ε'_NTMap_app_I: "ε'NTMap𝔞PL = εNTMap𝔞PL A f'"
      by 
        (
          cs_prems 
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_parallel_cs_intros
        )
    fix f'' assume prems: 
      "f'' : E'  E" "ε'NTMap𝔞PL = εNTMap𝔞PL A f''"
    have "ε' = ε NTCF ntcf_const ?II  f''"
    proof(rule ntcf_eqI[OF ])
      show "ε' : cf_const ?II  E' CF ?II_II : ?II ↦↦Cα "
        by (rule ε'.is_ntcf_axioms)
      from f' prems(1) show "ε NTCF ntcf_const ?II  f'' :
        cf_const ?II  E' CF ?II_II : ?II ↦↦Cα "
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show "ε'NTMap = (ε NTCF ntcf_const ?II  f'')NTMap"
      proof(rule vsv_eqI, unfold cat_cs_simps)
        show "vsv ((ε NTCF ntcf_const ?II  f'')NTMap)"
          by (cs_concl cs_intro: cat_cs_intros)
        from prems(1) show 
          "?IIObj = 𝒟 ((ε NTCF ntcf_const ?II  f'')NTMap)"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        fix a assume prems': "a  ?IIObj"
        note [cat_cs_simps] = 
          cat_eq_2_eps_NTMap_app
          cat_cone_cf_par_eps_NTMap_app[
            OF ε'.is_cat_cone_axioms cf_parallel_𝔤' cf_parallel_𝔣'
            ]
        from prems' prems(1) have [cat_cs_simps]: 
          "ε'NTMapa = εNTMapa A f''"
          by (elim the_cat_parallel_ObjE; simp only:)
            (
                cs_concl 
                  cs_simp: cat_cs_simps cat_parallel_cs_simps prems(2)
                  cs_intro: cat_cs_intros cat_parallel_cs_intros
            )+
        from prems' prems show 
          "ε'NTMapa = (ε NTCF ntcf_const ?II  f'')NTMapa"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      qed auto
    qed simp_all
    from unique[OF prems(1) this] show "f'' = f'" .      
  qed
qed

lemma (in is_cat_equalizer) cat_eq_unique:
  assumes "ε' : E' <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "
  shows 
    "∃!f'. f' : E'  E  ε' = ε NTCF ntcf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  f'"
  by (rule cat_lim_unique[OF is_cat_equalizerD(1)[OF assms]])

lemma (in is_cat_equalizer) cat_eq_unique':
  assumes "ε' : E' <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "
  shows "∃!f'. f' : E'  E  ε'NTMap𝔞PL = εNTMap𝔞PL A f'"
proof-
  interpret ε': is_cat_equalizer α 𝔞 𝔟 𝔤 𝔣  E' ε' by (rule assms(1))
  show ?thesis by (rule cat_eq_unique_cone[OF ε'.is_cat_cone_axioms])
qed

lemma (in is_cat_coequalizer) cat_coeq_unique_cocone:
  assumes "ε' :
    ↑↑→↑↑  𝔟PL 𝔞PL 𝔣PL 𝔤PL 𝔟 𝔞 𝔣 𝔤 >CF.cocone E' : ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL ↦↦Cα "
    (is ε' : ?II_II >CF.cocone E' : ?II ↦↦Cα )
  shows "∃!f'. f' : E  E'  ε'NTMap𝔞PL = f' A εNTMap𝔞PL"
proof-
  interpret ε': is_cat_cocone α E' ?II  ?II_II ε' by (rule assms(1))
  have [cat_op_simps]:
    "f' : E  E'  ε'NTMap𝔞PL = εNTMap𝔞PL Aop_cat  f' 
      f' : E  E'  ε'NTMap𝔞PL = f' A εNTMap𝔞PL" 
    for f'
    by (intro iffI conjI; (elim conjE)?)
      (
        cs_concl
          cs_simp: category.op_cat_Comp[symmetric] cat_op_simps cat_cs_simps 
          cs_intro: cat_cs_intros cat_parallel_cs_intros
      )+
  show ?thesis
    by 
      (
        rule is_cat_equalizer.cat_eq_unique_cone[
          OF is_cat_equalizer_op ε'.is_cat_cone_op[unfolded cat_op_simps],
          unfolded cat_op_simps
          ]
     )
qed

lemma (in is_cat_coequalizer) cat_coeq_unique:
  assumes "ε' : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E' : ↑↑2C ↦↦Cα "
  shows "∃!f'.
    f' : E  E' 
    ε' = ntcf_const (↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL)  f' NTCF ε"
  by (rule cat_colim_unique[OF is_cat_coequalizerD(1)[OF assms]])

lemma (in is_cat_coequalizer) cat_coeq_unique':
  assumes "ε' : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E' : ↑↑2C ↦↦Cα "
  shows "∃!f'. f' : E  E'  ε'NTMap𝔞PL = f' A εNTMap𝔞PL"
proof-
  interpret ε': is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E' ε' by (rule assms(1))
  show ?thesis by (rule cat_coeq_unique_cocone[OF ε'.is_cat_cocone_axioms])
qed

lemma cat_equalizer_2_ex_is_arr_isomorphism:
  assumes "ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα " 
    and "ε' : E' <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "
  obtains f where "f : E' iso E"
    and "ε' = ε NTCF ntcf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  f"
proof-
  interpret ε: is_cat_equalizer α 𝔞 𝔟 𝔤 𝔣  E ε by (rule assms(1))
  interpret ε': is_cat_equalizer α 𝔞 𝔟 𝔤 𝔣  E' ε' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_lim_ex_is_arr_isomorphism[
          OF ε.is_cat_limit_axioms ε'.is_cat_limit_axioms
          ]
      )
qed

lemma cat_equalizer_2_ex_is_arr_isomorphism':
  assumes "ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα " 
    and "ε' : E' <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "
  obtains f where "f : E' iso E"
    and "ε'NTMap𝔞PL = εNTMap𝔞PL A f"
    and "ε'NTMap𝔟PL = εNTMap𝔟PL A f"
proof-
  interpret ε: is_cat_equalizer α 𝔞 𝔟 𝔤 𝔣  E ε by (rule assms(1))
  interpret ε': is_cat_equalizer α 𝔞 𝔟 𝔤 𝔣  E' ε' by (rule assms(2))
  obtain f where f: "f : E' iso E"
    and "j  ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PLObj  ε'NTMapj = εNTMapj A f" for j
    by 
      (
        elim cat_lim_ex_is_arr_isomorphism'[
          OF ε.is_cat_limit_axioms ε'.is_cat_limit_axioms
          ]
      )
  then have 
    "ε'NTMap𝔞PL = εNTMap𝔞PL A f"
    "ε'NTMap𝔟PL = εNTMap𝔟PL A f"
    unfolding the_cat_parallel_components by auto
  with f show ?thesis using that by simp
qed

lemma cat_coequalizer_2_ex_is_arr_isomorphism:
  assumes "ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "
    and "ε' : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E' : ↑↑2C ↦↦Cα "
  obtains f where "f : E iso E'" 
    and "ε' = ntcf_const (↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PL)   f NTCF ε"
proof-
  interpret ε: is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E ε by (rule assms(1))
  interpret ε': is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E' ε' by (rule assms(2))
  from that show ?thesis
    by 
      (
        elim cat_colim_ex_is_arr_isomorphism[
          OF ε.is_cat_colimit_axioms ε'.is_cat_colimit_axioms
          ]
      )
qed

lemma cat_coequalizer_2_ex_is_arr_isomorphism':
  assumes "ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "
    and "ε' : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E' : ↑↑2C ↦↦Cα "
  obtains f where "f : E iso E'" 
    and "ε'NTMap𝔞PL = f A εNTMap𝔞PL"
    and "ε'NTMap𝔟PL = f A εNTMap𝔟PL"
proof-
  interpret ε: is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E ε by (rule assms(1))
  interpret ε': is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E' ε' by (rule assms(2))
  obtain f where f: "f : E iso E'"
    and "j  ↑↑C 𝔟PL 𝔞PL 𝔣PL 𝔤PLObj  ε'NTMapj = f A εNTMapj" for j
    by 
      (
        elim cat_colim_ex_is_arr_isomorphism'[
          OF ε.is_cat_colimit_axioms ε'.is_cat_colimit_axioms
          ]
      )
  then have 
    "ε'NTMap𝔞PL = f A εNTMap𝔞PL"
    "ε'NTMap𝔟PL = f A εNTMap𝔟PL"
    unfolding the_cat_parallel_components by auto
  with f show ?thesis using that by simp
qed



subsection‹Projection cone›


subsubsection‹Definition and elementary properties›

definition ntcf_obj_prod_base :: "V  V  (V  V)  V  (V  V)  V"
  where "ntcf_obj_prod_base  I F P f =
    [(λj:C IObj. f j), cf_const (:C I)  P, :→: I F , :C I, ]"


text‹Components.›

lemma ntcf_obj_prod_base_components:
  shows "ntcf_obj_prod_base  I F P fNTMap = (λj:C IObj. f j)"
    and "ntcf_obj_prod_base  I F P fNTDom = cf_const (:C I)  P"
    and "ntcf_obj_prod_base  I F P fNTCod = :→: I F "
    and "ntcf_obj_prod_base  I F P fNTDGDom = :C I"
    and "ntcf_obj_prod_base  I F P fNTDGCod = "
  unfolding ntcf_obj_prod_base_def nt_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Natural transformation map›

mk_VLambda ntcf_obj_prod_base_components(1)
  |vsv ntcf_obj_prod_base_NTMap_vsv[cat_cs_intros]|
  |vdomain ntcf_obj_prod_base_NTMap_vdomain[cat_cs_simps]|
  |app ntcf_obj_prod_base_NTMap_app[cat_cs_simps]|


subsubsection‹Projection natural transformation is a cone›

lemma (in tm_cf_discrete) tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone:
  assumes "P  Obj" and "a. a  I  f a : P  F a"
  shows "ntcf_obj_prod_base  I F P f : P <CF.cone :→: I F  : :C I ↦↦Cα "
proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')
  from assms(2) have [cat_cs_intros]: 
    " a  I; P' = P; Fa = F a   f a : P'  Fa" for a P' Fa 
    by simp
  show "vfsequence (ntcf_obj_prod_base  I F P f)"
    unfolding ntcf_obj_prod_base_def by auto
  show "vcard (ntcf_obj_prod_base  I F P f) = 5"
    unfolding ntcf_obj_prod_base_def by (auto simp: nat_omega_simps)
  from assms show "cf_const (:C I)  P : :C I ↦↦Cα "
    by 
      (
        cs_concl
          cs_intro: 
            cf_discrete_vdomain_vsubset_Vset 
            cat_discrete_cs_intros 
            cat_cs_intros
      )
  show ":→: I F  : :C I ↦↦Cα "
    by (cs_concl cs_intro: cat_discrete_cs_intros)
  show "ntcf_obj_prod_base  I F P fNTMapa :
    cf_const (:C I)  PObjMapa  :→: I F ObjMapa"
    if "a  :C IObj" for a
  proof-
    from that have "a  I" unfolding the_cat_discrete_components by simp
    from that this show ?thesis
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_discrete_cs_simps cs_intro: cat_cs_intros
        )
  qed
  show 
    "ntcf_obj_prod_base  I F P fNTMapb A
      cf_const (:C I)  PArrMapg =
      :→: I F ArrMapg A ntcf_obj_prod_base  I F P fNTMapa"
    if "g : a :C I b" for a b g
  proof-
    note g = the_cat_discrete_is_arrD[OF that]
    from that g(4)[unfolded g(7-9)] g(1)[unfolded g(7-9)] show ?thesis
      unfolding g(7-9)
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_discrete_cs_simps 
            cs_intro: 
              cf_discrete_vdomain_vsubset_Vset 
              cat_cs_intros cat_discrete_cs_intros
        )
  qed
  from assms(1) show "cf_const (:C I)  P : :C I ↦↦C.tmα "
    by 
      (
        cs_concl cs_intro: 
          cat_cs_intros cat_small_cs_intros cat_small_discrete_cs_intros
      )
qed 
  (
    auto simp: 
      assms 
      ntcf_obj_prod_base_components 
      tm_cf_discrete_the_cf_discrete_is_tm_functor
  )

lemma (in tm_cf_discrete) tm_cf_discrete_ntcf_obj_prod_base_is_cat_obj_prod:
  assumes "P  Obj" 
    and "a. a  I  f a : P  F a"
    and "u' r'.
       u' : r' <CF.cone :→: I F  : :C I ↦↦Cα    
        ∃!f'.
          f' : r'  P 
          u' = ntcf_obj_prod_base  I F P f NTCF ntcf_const (:C I)  f'"
  shows "ntcf_obj_prod_base  I F P f : P <CF. F : I ↦↦Cα "
proof
  (
    intro 
      is_cat_obj_prodI 
      is_cat_limitI' 
      tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone[OF assms(1,2), simplified] 
      assms(1,3)
  )
  show "cf_discrete α I F "
    by (cs_concl cs_intro: cat_small_discrete_cs_intros)
qed



subsection‹Equalizer cone›


subsubsection‹Definition and elementary properties›

definition ntcf_equalizer_base :: "V  V  V  V  V  V  (V  V)  V"
  where "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E e =
    [
      (λx↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PLObj. e x),
      cf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  E,
      ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣,
      ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL,
      
    ]"


text‹Components.›

lemma ntcf_equalizer_base_components:
  shows "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTMap =
    (λx↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PLObj. e x)"
    and [cat_lim_cs_simps]: "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTDom =
      cf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  E"
    and [cat_lim_cs_simps]: "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTCod =
      ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣"
    and [cat_lim_cs_simps]: 
      "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTDGDom = ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL"
    and [cat_lim_cs_simps]: 
      "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTDGCod = "
  unfolding ntcf_equalizer_base_def nt_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Natural transformation map›

mk_VLambda ntcf_equalizer_base_components(1)
  |vsv ntcf_equalizer_base_NTMap_vsv[cat_lim_cs_intros]|
  |vdomain ntcf_equalizer_base_NTMap_vdomain[cat_lim_cs_simps]|
  |app ntcf_equalizer_base_NTMap_app[cat_lim_cs_simps]|


subsubsection‹Equalizer cone is a cone›

lemma (in category) cat_ntcf_equalizer_base_is_cat_cone:
  assumes "e 𝔞PL : E  𝔞"
    and "e 𝔟PL : E  𝔟"
    and "e 𝔟PL = 𝔤 A e 𝔞PL"
    and "e 𝔟PL = 𝔣 A e 𝔞PL"
    and "𝔤 : 𝔞  𝔟"
    and "𝔣 : 𝔞  𝔟"
  shows "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E e :
    E <CF.cone ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 :
    ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα "
proof-
  interpret par: cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣  
    by (intro cf_parallelI cat_parallelI assms(5,6))
      (simp_all add: cat_parallel_cs_intros cat_cs_intros)
  show ?thesis
  proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')
    show "vfsequence (ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E e)"
      unfolding ntcf_equalizer_base_def by auto
    show "vcard (ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E e) = 5"
      unfolding ntcf_equalizer_base_def by (simp add: nat_omega_simps)
    from assms(2) show 
      "cf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  E : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦C.tmα "
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps 
            cs_intro: cat_small_cs_intros cat_parallel_cs_intros cat_cs_intros
        )
    then show "cf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  E : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα "
      by (cs_concl cs_intro: cat_small_cs_intros)
    from assms show 
      "↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦C.tmα "
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_parallel_cs_intros)
    then show "↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣 : ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL ↦↦Cα "
      by (cs_concl cs_intro: cat_small_cs_intros)
    show 
      "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTMapi :
        cf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  EObjMapi 
        ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣ObjMapi"
      if "i  ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PLObj" for i 
    proof-
      from that assms(1,2,5,6) show ?thesis
        by (elim the_cat_parallel_ObjE; simp only:)
          ( 
            cs_concl 
              cs_simp: cat_lim_cs_simps cat_cs_simps cat_parallel_cs_simps 
              cs_intro: cat_cs_intros cat_parallel_cs_intros
          )
    qed
    show 
      "ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTMapb' A
        cf_const (↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL)  EArrMapf' =
          ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣ArrMapf' A
          ntcf_equalizer_base  𝔞 𝔟 𝔤 𝔣 E eNTMapa'"
      if "f' : a' ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL b'" for a' b' f'
      using that assms(1,2,5,6)
      by (elim par.the_cat_parallel_is_arrE; simp only:)
        (
          cs_concl 
            cs_simp: 
              cat_cs_simps 
              cat_lim_cs_simps 
              cat_parallel_cs_simps 
              assms(3,4)[symmetric]
            cs_intro: cat_parallel_cs_intros
        )+
  qed 
    (
      use assms(2) in 
        cs_concl
            cs_intro: cat_lim_cs_intros cat_cs_intros 
            cs_simp: cat_lim_cs_simps
    )+
qed



subsection‹Limits by products and equalizers›

lemma cat_limit_of_cat_prod_obj_and_cat_equalizer:
  ―‹See Theorem 1 in Chapter V-2 in \cite{mac_lane_categories_2010}.›
  assumes "𝔉 : 𝔍 ↦↦C.tmα "
    and "𝔞 𝔟 𝔤 𝔣.  𝔣 : 𝔞  𝔟; 𝔤 : 𝔞  𝔟  
      E ε. ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "
    and "A. tm_cf_discrete α (𝔍Obj) A  
      P π. π : P <CF. A : 𝔍Obj ↦↦Cα "
    and "A. tm_cf_discrete α (𝔍Arr) A  
      P π. π : P <CF. A : 𝔍Arr ↦↦Cα "
  obtains r u where "u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "
proof-

  let ?L =λu. 𝔉ObjMap𝔍Codu and ?R =λi. 𝔉ObjMapi
  
  interpret 𝔉: is_tm_functor α 𝔍  𝔉 by (rule assms(1))

  have "?R j  Obj" if "j  𝔍Obj" for j
    by (cs_concl cs_intro: cat_cs_intros that)

  have "tm_cf_discrete α (𝔍Obj) ?R "
  proof(intro tm_cf_discreteI)
    show "𝔉ObjMapi  Obj" if "i  𝔍Obj" for i
      by (cs_concl cs_intro: cat_cs_intros that)
    show "VLambda (𝔍Obj) ?R  Vset α"
    proof(rule vbrelation.vbrelation_Limit_in_VsetI)
      show " (VLambda (𝔍Obj) ?R)  Vset α"
      proof-
        have " (VLambda (𝔍Obj) ?R)   (𝔉ObjMap)"
          by (auto simp: 𝔉.cf_ObjMap_vdomain)
        moreover have " (𝔉ObjMap)  Vset α"
          by (force intro: vrange_in_VsetI 𝔉.tm_cf_ObjMap_in_Vset)
        ultimately show ?thesis by auto
      qed
    qed (auto simp: cat_small_cs_intros)
    show "(λi𝔍Obj. CId𝔉ObjMapi)  Vset α"
    proof(rule vbrelation.vbrelation_Limit_in_VsetI)
      show " (λi𝔍Obj. CId𝔉ObjMapi)  Vset α"
      proof-
        have " (λi𝔍Obj. CId𝔉ObjMapi)   (𝔉ArrMap)"
        proof(rule vrange_VLambda_vsubset)
          fix x assume x: "x  𝔍Obj"
          then have "𝔍CIdx  𝒟 (𝔉ArrMap)"
            by (auto intro: cat_cs_intros simp: cat_cs_simps)
          moreover from x have "CId𝔉ObjMapx = 𝔉ArrMap𝔍CIdx"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          ultimately show "CId𝔉ObjMapx   (𝔉ArrMap)"
            by (simp add: 𝔉.ArrMap.vsv_vimageI2)
        qed
        moreover have " (𝔉ArrMap)  Vset α"
          by (force intro: vrange_in_VsetI 𝔉.tm_cf_ArrMap_in_Vset)
        ultimately show ?thesis by auto
      qed
    qed (auto simp: cat_small_cs_intros)
  qed (auto intro: cat_cs_intros)

  from assms(3)[where A=?R, OF this] obtain PO πO
    where πO: "πO : PO <CF. ?R : 𝔍Obj ↦↦Cα "
    by clarsimp

  interpret πO: is_cat_obj_prod α 𝔍Obj ?R  PO πO by (rule πO)

  have PO: "PO  Obj" by (intro πO.cat_cone_obj)

  have "?L u  Obj" if "u  𝔍Arr" for u
  proof-
    from that obtain a b where "u : a 𝔍 b" by auto
    then show ?thesis by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  qed

  have tm_cf_discrete: "tm_cf_discrete α (𝔍Arr) ?L "
  proof(intro tm_cf_discreteI)
    show "𝔉ObjMap𝔍Codf  Obj" if "f  𝔍Arr" for f
    proof-
      from that obtain a b where "f : a 𝔍 b" by auto
      then show ?thesis 
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    qed
 
    show "(λu𝔍Arr. 𝔉ObjMap𝔍Codu)  Vset α"
    proof(rule vbrelation.vbrelation_Limit_in_VsetI)
      show " (λu𝔍Arr. ?L u)  Vset α"
      proof-
        have " (λu𝔍Arr. ?L u)   (𝔉ObjMap)"
        proof(rule vrange_VLambda_vsubset)
          fix f assume "f  𝔍Arr"
          then obtain a b where "f : a 𝔍 b" by auto
          then show "𝔉ObjMap𝔍Codf   (𝔉ObjMap)"
            by 
              (
                cs_concl 
                  cs_simp: cat_cs_simps cs_intro: V_cs_intros cat_cs_intros
              )
        qed
        moreover have " (𝔉ObjMap)  Vset α"
          by (auto intro: vrange_in_VsetI 𝔉.tm_cf_ObjMap_in_Vset)
        ultimately show ?thesis by auto
      qed
    qed (auto simp: cat_small_cs_intros)

    show "(λi𝔍Arr. CId𝔉ObjMap𝔍Codi)  Vset α"
    proof(rule vbrelation.vbrelation_Limit_in_VsetI)
      show " (λi𝔍Arr. CId𝔉ObjMap𝔍Codi)  Vset α"
      proof-
        have " (λi𝔍Arr. CId𝔉ObjMap𝔍Codi)   (𝔉ArrMap)"
        proof(rule vrange_VLambda_vsubset)
          fix f assume "f  𝔍Arr"
          then obtain a b where f: "f : a 𝔍 b" by auto
          then have "𝔍CIdb  𝒟 (𝔉ArrMap)"
            by (auto intro: cat_cs_intros simp: cat_cs_simps)
          moreover from f have 
            "CId𝔉ObjMap𝔍Codf = 𝔉ArrMap𝔍CIdb"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          ultimately show "CId𝔉ObjMap𝔍Codf   (𝔉ArrMap)"
            by (simp add: 𝔉.ArrMap.vsv_vimageI2)
        qed
        moreover have " (𝔉ArrMap)  Vset α"
          by (force intro: vrange_in_VsetI 𝔉.tm_cf_ArrMap_in_Vset)
        ultimately show ?thesis by auto
      qed
    qed (auto simp: cat_small_cs_intros)
  qed (auto intro: cat_cs_intros)

  from assms(4)[where A=?L, OF this, simplified] obtain PA πA
    where πA: "πA : PA <CF. ?L : 𝔍Arr ↦↦Cα "
    by auto

  interpret πA: is_cat_obj_prod α 𝔍Arr ?L  PA πA by (rule πA)

  let ?F = λu. 𝔉ObjMap𝔍Codu and ?f = λu. πONTMap𝔍Codu 
  let O' = ‹ntcf_obj_prod_base  (:C (𝔍Arr)Obj) ?F PO ?f

  have πO': "O' :
    PO <CF.cone :→: (𝔍Arr) (λu. 𝔉ObjMap𝔍Codu)  :
    :C (𝔍Arr) ↦↦Cα "
    unfolding the_cat_discrete_components(1)
  proof
    (
      intro 
        tm_cf_discrete.tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone 
        tm_cf_discrete
    )
    fix f assume "f  𝔍Arr"
    then obtain a b where "f : a 𝔍 b" by auto
    then show "πONTMap𝔍Codf : PO  𝔉ObjMap𝔍Codf"
      by 
        (
          cs_concl
            cs_simp:
              the_cat_discrete_components(1) cat_discrete_cs_simps cat_cs_simps
            cs_intro: cat_cs_intros
        )
  qed (intro PO)

  from πA.cat_obj_prod_unique_cone'[OF πO'] obtain f' 
    where f': "f' : PO  PA"
      and πO'_NTMap_app: 
        "j. j  𝔍Arr  O'NTMapj = πANTMapj A f'"
      and unique_f':
        "
          f'' : PO  PA;
          j. j  𝔍Arr  O'NTMapj = πANTMapj A f''
           f'' = f'"
      for f''
    by metis

  have πO_NTMap_app_Cod: 
    "πONTMapb = πANTMapf A f'" if "f : a 𝔍 b" for f a b 
  proof-
    from that have "f  𝔍Arr" by auto
    from πO'_NTMap_app[OF this] that show ?thesis
      by 
        (
          cs_prems 
            cs_simp: cat_cs_simps the_cat_discrete_components(1)
            cs_intro: cat_cs_intros
        )
  qed

  from this[symmetric] have πA_NTMap_Comp_app: 
    "πANTMapf A (f' A q) = πONTMapb A q" 
    if "f : a 𝔍 b" and "q : c  PO" for q f a b c 
    using that f'
    by (intro 𝔉.HomCod.cat_assoc_helper)
      (
        cs_concl 
          cs_simp: 
            cat_cs_simps cat_discrete_cs_simps the_cat_discrete_components(1)
          cs_intro: cat_cs_intros
      )+

  let ?g = λu. 𝔉ArrMapu A πONTMap𝔍Domu 
  let O'' = ‹ntcf_obj_prod_base  (:C (𝔍Arr)Obj) ?F PO ?g
  
  have πO'': "O'' : PO <CF.cone :→: (𝔍Arr) ?L  : :C (𝔍Arr) ↦↦Cα "
    unfolding the_cat_discrete_components(1)
  proof
    (
      intro 
        tm_cf_discrete.tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone  
        tm_cf_discrete
    )
    show "𝔉ArrMapf A πONTMap𝔍Domf : PO  𝔉ObjMap𝔍Codf"
      if "f  𝔍Arr" for f
    proof-
      from that obtain a b where "f : a 𝔍 b"  by auto
      then show ?thesis
        by  
          (
            cs_concl 
              cs_simp: 
                cat_cs_simps cat_discrete_cs_simps 
                the_cat_discrete_components(1) 
              cs_intro: cat_cs_intros
          )
    qed
  qed (intro PO)

  from πA.cat_obj_prod_unique_cone'[OF πO''] obtain g' 
    where g': "g' : PO  PA"
      and πO''_NTMap_app: 
        "j. j  𝔍Arr  O''NTMapj = πANTMapj A g'"
      and unique_g':
        "
          g'' : PO  PA;
          j. j  𝔍Arr  O''NTMapj = πANTMapj A g''
           g'' = g'"
      for g''
    by (metis (lifting))

  have "𝔉ArrMapf A πONTMapa = πANTMapf A g'" 
    if "f : a 𝔍 b" for f a b 
  proof-
    from that have "f  𝔍Arr" by auto
    from πO''_NTMap_app[OF this] that show ?thesis
      by 
        (
          cs_prems 
            cs_simp: cat_cs_simps the_cat_discrete_components(1)
            cs_intro: cat_cs_intros
        )
  qed
  then have πO_NTMap_app_Dom: 
    "𝔉ArrMapf A (πONTMapa A q) =
      (πANTMapf A g') A q" 
    if "f : a 𝔍 b" and "q : c   PO" for q f a b c 
    using that g' 
    by (intro 𝔉.HomCod.cat_assoc_helper)
      (
        cs_concl 
          cs_simp: 
            cat_cs_simps cat_discrete_cs_simps the_cat_discrete_components(1)
          cs_intro: cat_cs_intros
      )

  from assms(2)[OF f' g'] obtain E ε where ε: 
    "ε : E <CF.eq (PO,PA,g',f') : ↑↑2C ↦↦Cα "
    by clarsimp

  interpret ε: is_cat_equalizer α PO PA g' f'  E ε by (rule ε)

  define μ where "μ =
    [(λi𝔍Obj. πONTMapi A εNTMap𝔞PL), cf_const 𝔍  E, 𝔉, 𝔍, ]"

  have μ_components:
    "μNTMap = (λi𝔍Obj. πONTMapi A εNTMap𝔞PL)"
    "μNTDom = cf_const 𝔍  E"
    "μNTCod = 𝔉"
    "μNTDGDom = 𝔍"
    "μNTDGCod = "
    unfolding μ_def nt_field_simps by (simp_all add: nat_omega_simps)

  have [cat_cs_simps]: 
    "μNTMapi = πONTMapi A εNTMap𝔞PL" if "i  𝔍Obj" 
    for i
    using that unfolding μ_components by simp

  have "μ : E <CF.lim 𝔉 : 𝔍 ↦↦Cα "
  proof(intro is_cat_limitI')

    show μ: "μ : E <CF.cone 𝔉 : 𝔍 ↦↦Cα " 
    proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')
      show "vfsequence μ" unfolding μ_def by simp 
      show "vcard μ = 5" unfolding μ_def by (simp add: nat_omega_simps)
      show "cf_const 𝔍  E : 𝔍 ↦↦Cα "
        by (cs_concl cs_intro: cat_cs_intros cat_lim_cs_intros)
      show "𝔉 : 𝔍 ↦↦Cα " by (cs_concl cs_intro: cat_cs_intros)
      show "μNTMapa : cf_const 𝔍  EObjMapa  𝔉ObjMapa"
        if "a  𝔍Obj" for a
        using that
        by 
          (
            cs_concl 
              cs_simp: 
                cat_cs_simps 
                cat_discrete_cs_simps 
                cat_parallel_cs_simps 
                the_cat_discrete_components(1) 
              cs_intro: cat_cs_intros cat_lim_cs_intros cat_parallel_cs_intros
          )
      show 
        "μNTMapb A cf_const 𝔍  EArrMapf =
          𝔉ArrMapf A μNTMapa"
        if "f : a 𝔍 b" for a b f
        using that ε g' f' 
        by 
          (
            cs_concl
              cs_simp:
                cat_parallel_cs_simps
                cat_cs_simps 
                the_cat_discrete_components(1) 
                πO_NTMap_app_Cod 
                πO_NTMap_app_Dom 
                ε.cat_eq_Comp_eq(1) 
              cs_intro: cat_lim_cs_intros cat_cs_intros cat_parallel_cs_intros
          )
      show "cf_const 𝔍  E : 𝔍 ↦↦C.tmα "
        by 
          (
            cs_concl cs_simp: cs_intro: 
              cat_lim_cs_intros cat_cs_intros cat_small_cs_intros
          )
      show "𝔉 : 𝔍 ↦↦C.tmα "
        by (cs_concl cs_simp: cs_intro: cat_small_cs_intros)

    qed (auto simp: μ_components cat_lim_cs_intros)

    interpret μ: is_cat_cone α E 𝔍  𝔉 μ by (rule μ)

    show "∃!f'. f' : r'  E  u' = μ NTCF ntcf_const 𝔍  f'"
      if "u' : r' <CF.cone 𝔉 : 𝔍 ↦↦Cα " for u' r'
    proof-

      interpret u': is_cat_cone α r' 𝔍  𝔉 u' by (rule that)

      let ?u' = λj. u'NTMapj 
      let ?π' = ‹ntcf_obj_prod_base  (𝔍Obj) ?R r' ?u'

      have π'_NTMap_app: "?π'NTMapj = u'NTMapj" if "j  𝔍Obj" for j
        using that 
        unfolding ntcf_obj_prod_base_components the_cat_discrete_components 
        by auto

      have π': "?π' : r' <CF.cone :→: (𝔍Obj) ?R  : :C (𝔍Obj) ↦↦Cα "
        unfolding the_cat_discrete_components(1)
      proof(intro tm_cf_discrete.tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone)
        show "tm_cf_discrete α (𝔍Obj) ?R "
        proof(intro tm_cf_discreteI)
          show "𝔉ObjMapi  Obj" if "i  𝔍Obj" for i
            using that 
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        qed
          (
            auto intro: 
              cat_cs_intros
              PO 
              πO.NTCod.tm_cf_ArrMap_in_Vset[unfolded the_cf_discrete_components]
              πO.NTCod.tm_cf_ObjMap_in_Vset[unfolded the_cf_discrete_components]
          )
        show "u'NTMapj : r'  𝔉ObjMapj" if "j  𝔍Obj" for j
          using that by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      qed (auto simp: cat_lim_cs_intros)

      from πO.cat_obj_prod_unique_cone'[OF this] obtain h' 
        where h': "h' : r'  PO"
          and π'_NTMap_app': 
            "j. j  (𝔍Obj)  ?π'NTMapj = πONTMapj A h'"
          and unique_h': "h''.
             
              h'' : r'  PO;
              j. j  (𝔍Obj)  ?π'NTMapj = πONTMapj A h'' 
              h'' = h'"
        by metis

      interpret π':
        is_cat_cone α r' :C (𝔍Obj)  :→: (𝔍Obj) (app (𝔉ObjMap))  ?π'
        by (rule π')

      let ?u'' = λu. u'NTMap𝔍Codu 
      let ?π'' = ‹ntcf_obj_prod_base  (𝔍Arr) ?L r' ?u''

      have π''_NTMap_app: "?π''NTMapf = u'NTMapb"
        if "f : a 𝔍 b" for f a b 
        using that 
        unfolding ntcf_obj_prod_base_components the_cat_discrete_components 
        by (cs_concl cs_simp: V_cs_simps cat_cs_simps cs_intro: cat_cs_intros)
      
      have π'': "?π'' : r' <CF.cone :→: (𝔍Arr) ?L  : :C (𝔍Arr) ↦↦Cα "
        unfolding the_cat_discrete_components(1)
      proof
        (
          intro 
            tm_cf_discrete.tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone 
            tm_cf_discrete
        )
        fix f assume "f  𝔍Arr"
        then obtain a b where "f : a 𝔍 b" by auto
        then show "u'NTMap𝔍Codf : r'  𝔉ObjMap𝔍Codf"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      qed (simp add: cat_lim_cs_intros)

      from πA.cat_obj_prod_unique_cone'[OF this] obtain h'' 
        where h'': "h'' : r'  PA"
          and π''_NTMap_app': 
            "j. j  𝔍Arr  ?π''NTMapj = πANTMapj A h''"
          and unique_h'': "h'''.
             
              h''' : r'  PA;
              j. j  𝔍Arr  ?π''NTMapj = πANTMapj A h''' 
              h''' = h''"
        by metis

      interpret π'': is_cat_cone α r' :C (𝔍Arr)  :→: (𝔍Arr) ?L  ?π''
        by (rule π'')

      have g'h'_f'h': "g' A h' = f' A h'"  
      proof-

        from g' h' have g'h': "g' A h' : r'  PA"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        from f' h' have f'h': "f' A h' : r'  PA"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

        have "?π''NTMapf = πANTMapf A (g' A h')"
          if "f  𝔍Arr" for f
        proof-
          from that obtain a b where f: "f : a 𝔍 b" by auto
          then have "?π''NTMapf = u'NTMapb"
            by (cs_concl cs_simp: π''_NTMap_app cat_cs_simps)
          also from f have " = 𝔉ArrMapf A ?π'NTMapa"
            by 
              (
                cs_concl 
                  cs_simp: π'_NTMap_app cat_lim_cs_simps cs_intro: cat_cs_intros
              )
          also from f g' h' have " = πANTMapf A (g' A h')" 
            by 
              (
                cs_concl
                  cs_simp: 
                    cat_cs_simps 
                    cat_discrete_cs_simps
                    the_cat_discrete_components(1) 
                    π'_NTMap_app'
                    πO_NTMap_app_Dom 
                  cs_intro: cat_cs_intros
              )
          finally show ?thesis by simp
        qed
          
        from unique_h''[OF g'h' this, simplified] have g'h'_h'': 
          "g' A h' = h''".
        have "?π''NTMapf = πANTMapf A (f' A h')"
          if "f  𝔍Arr" for f
        proof-
          from that obtain a b where f: "f : a 𝔍 b" by auto
          then have "?π''NTMapf = u'NTMapb"
            by (cs_concl cs_simp: π''_NTMap_app cat_cs_simps)
          also from f have " = ?π'NTMapb"
            by (cs_concl cs_simp: π'_NTMap_app cs_intro: cat_cs_intros)
          also from f have " = πONTMapb A h'"
            by (cs_concl cs_simp: π'_NTMap_app' cs_intro: cat_cs_intros)
          also from f g' h' have " = (πANTMapf A f') A h'"
            by (cs_concl cs_simp: πO_NTMap_app_Cod cs_intro: cat_cs_intros)
          also from that f' h' have " = πANTMapf A (f' A h')"
            by 
              (
                cs_concl
                  cs_simp: cat_cs_simps the_cat_discrete_components(1) 
                  cs_intro: cat_cs_intros
               )
          finally show ?thesis by simp
        qed
        from unique_h''[OF f'h' this, simplified] have f'h'_h'': 
          "f' A h' = h''".
        from g'h'_h'' f'h'_h'' show ?thesis by simp
      qed

      let ?II = ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL 
        and ?II_II = ↑↑→↑↑  𝔞PL 𝔟PL 𝔤PL 𝔣PL PO PA g' f'

    define ε' where "ε' =
      [
        (λf?IIObj. (f = 𝔞PL ? h' : (f' A h'))),
        cf_const ?II  r',
        ?II_II,
        ?II,
        
      ]"

    have ε'_components: 
      "ε'NTMap = (λf?IIObj. (f = 𝔞PL ? h' : (f' A h')))"
      "ε'NTDom = cf_const ?II  r'"
      "ε'NTCod = ?II_II"
      "ε'NTDGDom = ?II"
      "ε'NTDGCod = "
      unfolding ε'_def nt_field_simps by (simp_all add: nat_omega_simps)

    have ε'_NTMap_app_I2: "ε'NTMapx = h'" if "x = 𝔞PL" for x 
    proof-
      have "x  ?IIObj"
        unfolding that by (cs_concl cs_intro: cat_parallel_cs_intros)
      then show ?thesis unfolding ε'_components that by simp
    qed

    have ε'_NTMap_app_sI2: "ε'NTMapx = f' A h'" if "x = 𝔟PL" for x 
    proof-      
      have "x  ?IIObj"
        unfolding that by (cs_concl cs_intro: cat_parallel_cs_intros)
      with ε.cat_parallel_𝔞𝔟 show ?thesis
        unfolding ε'_components by (cs_concl cs_simp: V_cs_simps that)
    qed

    interpret par: cf_parallel α 𝔞PL 𝔟PL 𝔤PL 𝔣PL PO PA g' f' 
      by (intro cf_parallelI cat_parallelI)
        (
          simp_all add: 
            cat_cs_intros cat_parallel_cs_intros cat_PL_ineq[symmetric]
        )

    have "ε' : r' <CF.cone ?II_II : ?II ↦↦Cα "
    proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')
      show "vfsequence ε'" unfolding ε'_def by auto
      show "vcard ε' = 5" unfolding ε'_def by (simp add: nat_omega_simps)
      from h' show "cf_const (?II)  r' : ?II ↦↦Cα "
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show "?II_II : ?II ↦↦Cα "
        by (cs_concl cs_simp: cat_parallel_cs_simps cs_intro: cat_cs_intros)
      from h' show "ε'NTMapa : 
        cf_const ?II  r'ObjMapa  ?II_IIObjMapa"
        if "a  ?IIObj" for a 
        using that
        by (elim the_cat_parallel_ObjE; simp only:)
          (
            cs_concl 
              cs_simp: 
                ε'_NTMap_app_I2 ε'_NTMap_app_sI2 
                cat_cs_simps cat_parallel_cs_simps 
              cs_intro: cat_cs_intros cat_parallel_cs_intros
          )
      from h' f' g'h'_f'h' show 
        "ε'NTMapb A cf_const ?II  r'ArrMapf =
          ?II_IIArrMapf A ε'NTMapa"
          if "f : a ?II b" for a b f
          using that
          by (elim ε.the_cat_parallel_is_arrE; simp only:)
            (
              cs_concl 
                cs_intro: cat_cs_intros cat_parallel_cs_intros 
                cs_simp:
                  cat_cs_simps
                  cat_parallel_cs_simps
                  ε'_NTMap_app_I2 
                  ε'_NTMap_app_sI2
            )+
      qed 
        (
          simp add: ε'_components | 
          cs_concl 
            cs_simp: cat_cs_simps 
            cs_intro: cat_lim_cs_intros cat_cs_intros cat_small_cs_intros 
        )+
    from ε.cat_eq_unique_cone[OF this] obtain t'
      where t': "t' : r'  E"
        and ε'_NTMap_app: "ε'NTMap𝔞PL = εNTMap𝔞PL A t'"
        and unique_t':
          " t'' : r'  E; ε'NTMap𝔞PL = εNTMap𝔞PL A t''  
            t'' = t'" 
        for t''
      by metis

    show "∃!f'. f' : r'  E  u' = μ NTCF ntcf_const 𝔍  f'"
    proof(intro ex1I conjI; (elim conjE)?, (rule t')?)
      show [symmetric, cat_cs_simps]: "u' = μ NTCF ntcf_const 𝔍  t'"
      proof(rule ntcf_eqI[OF u'.is_ntcf_axioms])
        from t' show 
          "μ NTCF ntcf_const 𝔍  t' : cf_const 𝔍  r' CF 𝔉 : 𝔍 ↦↦Cα "
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        show "u'NTMap = (μ NTCF ntcf_const 𝔍  t')NTMap"
        proof(rule vsv_eqI)
          show "vsv ((μ NTCF ntcf_const 𝔍  t')NTMap)"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          from t' show 
            "𝒟 (u'NTMap) = 𝒟 ((μ NTCF ntcf_const 𝔍  t')NTMap)"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          show "u'NTMapa = (μ NTCF ntcf_const 𝔍  t')NTMapa"
            if "a  𝒟 (u'NTMap)" for a
          proof-
            from that have "a  𝔍Obj" by (cs_prems cs_simp: cat_cs_simps)
            with t' show "u'NTMapa = (μ NTCF ntcf_const 𝔍  t')NTMapa"
              by 
                (
                  cs_concl
                    cs_simp:
                      cat_cs_simps 
                      π'_NTMap_app
                      cat_parallel_cs_simps
                      the_cat_discrete_components(1)
                      ε'_NTMap_app[symmetric]
                      ε'_NTMap_app_I2
                      π'_NTMap_app'[symmetric]
                    cs_intro: cat_cs_intros cat_parallel_cs_intros
                )
          qed
        qed auto
      qed simp_all

      fix t'' assume prems': 
        "t'' : r'  E" "u' = μ NTCF ntcf_const 𝔍  t''"
      then have u'_NTMap_app_x:
        "u'NTMapx = (μ NTCF ntcf_const 𝔍  t'')NTMapx"
        for x 
        by simp
      have "?π'NTMapj = πONTMapj A (εNTMap𝔞PL A t'')" 
        if "j  𝔍Obj" for j
        using u'_NTMap_app_x[of j] prems'(1) that
        by 
          (
            cs_prems 
              cs_simp:
                cat_cs_simps 
                cat_discrete_cs_simps 
                cat_parallel_cs_simps 
                the_cat_discrete_components(1) 
              cs_intro: cat_cs_intros cat_parallel_cs_intros
          ) 
          (simp add: π'_NTMap_app[OF that, symmetric])
      moreover from prems'(1) have "εNTMap𝔞PL A t'' : r'  PO"
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps cat_parallel_cs_simps 
              cs_intro: cat_cs_intros cat_parallel_cs_intros
          )
      ultimately have [cat_cs_simps]: 
        "εNTMap𝔞PL A t'' = h'" 
        by (intro unique_h') simp
      show "t'' = t'"
        by (rule unique_t', intro prems'(1)) 
          (cs_concl cs_simp: ε'_NTMap_app_I2 cat_cs_simps)
      qed
    qed
 
  qed
  
  then show ?thesis using that by clarsimp

qed

lemma cat_colimit_of_cat_prod_obj_and_cat_coequalizer:
  ―‹See Theorem 1 in Chapter V-2 in \cite{mac_lane_categories_2010}.›
  assumes "𝔉 : 𝔍 ↦↦C.tmα "
    and "𝔞 𝔟 𝔤 𝔣.  𝔣 : 𝔟  𝔞; 𝔤 : 𝔟  𝔞  
      E ε. ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "
    and "A. tm_cf_discrete α (𝔍Obj) A  
      P π. π : A >CF. P : 𝔍Obj ↦↦Cα "
    and "A. tm_cf_discrete α (𝔍Arr) A  
      P π. π : A >CF. P : 𝔍Arr ↦↦Cα "
  obtains r u where "u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα "
proof-
  interpret 𝔉: is_tm_functor α 𝔍  𝔉 by (rule assms(1))
  have "E ε. ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα op_cat "
    if "𝔣 : 𝔟  𝔞" "𝔤 : 𝔟  𝔞" for 𝔞 𝔟 𝔤 𝔣
  proof-
    from assms(2)[OF that(1,2)] obtain E ε 
      where ε: "ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "
      by clarsimp
    interpret ε: is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E ε by (rule ε)
    from ε.is_cat_equalizer_op[unfolded cat_op_simps] show ?thesis by auto
  qed
  moreover have "P π. π : P <CF. A : 𝔍Obj ↦↦Cα op_cat "
    if "tm_cf_discrete α (𝔍Obj) A (op_cat )" for A
  proof-
    interpret tm_cf_discrete α 𝔍Obj A ‹op_cat  by (rule that)
    from assms(3)[OF tm_cf_discrete_op[unfolded cat_op_simps]] obtain P π 
      where π: "π : A >CF. P : 𝔍Obj ↦↦Cα "
      by clarsimp 
    interpret π: is_cat_obj_coprod α 𝔍Obj A  P π by (rule π)
    from π.is_cat_obj_prod_op show ?thesis by auto
  qed
  moreover have "P π. π : P <CF. A : 𝔍Arr ↦↦Cα op_cat "
    if "tm_cf_discrete α (𝔍Arr) A (op_cat )" for A 
  proof-
    interpret tm_cf_discrete α 𝔍Arr A ‹op_cat  by (rule that)
    from assms(4)[OF tm_cf_discrete_op[unfolded cat_op_simps]] obtain P π 
      where π: "π : A >CF. P : 𝔍Arr ↦↦Cα "
      by clarsimp 
    interpret π: is_cat_obj_coprod α 𝔍Arr A  P π by (rule π)
    from π.is_cat_obj_prod_op show ?thesis by auto
  qed
  ultimately obtain u r where u: 
    "u : r <CF.lim op_cf 𝔉 : op_cat 𝔍 ↦↦Cα op_cat "
    by 
      (
        rule cat_limit_of_cat_prod_obj_and_cat_equalizer[
          OF 𝔉.is_tm_functor_op, unfolded cat_op_simps
          ]
      )
  interpret u: is_cat_limit α ‹op_cat 𝔍 ‹op_cat  ‹op_cf 𝔉 r u by (rule u)
  from u.is_cat_colimit_op[unfolded cat_op_simps] that show ?thesis by simp
qed

text‹\newpage›

end

Theory CZH_UCAT_Complete

(* Copyright 2021 (C) Mihails Milehins *)

section‹Completeness for categories›
theory CZH_UCAT_Complete
  imports CZH_UCAT_Limit
begin



subsection‹Small-complete category›


subsubsection‹Definition and elementary properties›

locale cat_small_complete = category α  for α  + 
  assumes cat_small_complete: 
    "𝔉 𝔍. 𝔉 : 𝔍 ↦↦C.tmα   u r. u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "

locale cat_small_cocomplete = category α  for α  + 
  assumes cat_small_cocomplete: 
    "𝔉 𝔍. 𝔉 : 𝔍 ↦↦C.tmα   u r. u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα "


text‹Rules.›

mk_ide rf cat_small_complete_def[unfolded cat_small_complete_axioms_def]
  |intro cat_small_completeI|
  |dest cat_small_completeD[dest]|
  |elim cat_small_completeE[elim]|

lemma cat_small_completeE'[elim]:
  assumes "cat_small_complete α " and "𝔉 : 𝔍 ↦↦C.tmα "
  obtains u r where "u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "
  using assms by auto

mk_ide rf cat_small_cocomplete_def[unfolded cat_small_cocomplete_axioms_def]
  |intro cat_small_cocompleteI|
  |dest cat_small_cocompleteD[dest]|
  |elim cat_small_cocompleteE[elim]|

lemma cat_small_cocompleteE'[elim]:
  assumes "cat_small_cocomplete α " and "𝔉 : 𝔍 ↦↦C.tmα "
  obtains u r where "u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα "
  using assms by auto


subsubsection‹Duality›

lemma (in cat_small_complete) cat_small_cocomplete_op[cat_op_intros]:
  "cat_small_cocomplete α (op_cat )"
proof(intro cat_small_cocompleteI)
  fix 𝔉 𝔍 assume "𝔉 : 𝔍 ↦↦C.tmα op_cat "
  then interpret 𝔉: is_tm_functor α 𝔍 ‹op_cat  𝔉 .
  from cat_small_complete[OF 𝔉.is_tm_functor_op[unfolded cat_op_simps]]
  obtain u r where u: "u : r <CF.lim op_cf 𝔉 : op_cat 𝔍 ↦↦Cα "
    by auto
  then interpret u: is_cat_limit α ‹op_cat 𝔍  ‹op_cf 𝔉 r u .
  from u.is_cat_colimit_op[unfolded cat_op_simps] show 
    "u r. u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα op_cat "
    by auto
qed (auto intro: cat_cs_intros)

lemmas [cat_op_intros] = cat_small_complete.cat_small_cocomplete_op

lemma (in cat_small_cocomplete) cat_small_complete_op[cat_op_intros]:
  "cat_small_complete α (op_cat )"
proof(intro cat_small_completeI)
  fix 𝔉 𝔍 assume prems: "𝔉 : 𝔍 ↦↦C.tmα op_cat "
  then interpret 𝔉: is_tm_functor α 𝔍 ‹op_cat  𝔉 .
  from cat_small_cocomplete[OF 𝔉.is_tm_functor_op[unfolded cat_op_simps]]
  obtain u r where u: "u : op_cf 𝔉 >CF.colim r : op_cat 𝔍 ↦↦Cα "
    by auto
  interpret u: is_cat_colimit α ‹op_cat 𝔍  ‹op_cf 𝔉 r u by (rule u)
  from u.is_cat_limit_op[unfolded cat_op_simps] show 
    "u r. u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα op_cat "
    by auto
qed (auto intro: cat_cs_intros)

lemmas [cat_op_intros] = cat_small_cocomplete.cat_small_complete_op


subsubsection‹A category with equalizers and small products is small-complete›

lemma (in category) cat_small_complete_if_eq_and_obj_prod:
  ―‹See Corollary 2 in Chapter V-2 in \cite{mac_lane_categories_2010}›
  assumes "𝔞 𝔟 𝔤 𝔣.  𝔣 : 𝔞  𝔟; 𝔤 : 𝔞  𝔟  
      E ε. ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα "
    and "A I. tm_cf_discrete α I A   P π. π : P <CF. A : I ↦↦Cα "
  shows "cat_small_complete α "
proof(intro cat_small_completeI)
  fix 𝔉 𝔍 assume prems: "𝔉 : 𝔍 ↦↦C.tmα "
  then interpret 𝔉: is_tm_functor α 𝔍  𝔉 .
  show "u r. u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "
    by (rule cat_limit_of_cat_prod_obj_and_cat_equalizer[OF prems assms(1)])
      (auto intro: assms(2))
qed (auto simp: cat_cs_intros)

lemma (in category) cat_small_cocomplete_if_eq_and_obj_prod:
  assumes "𝔞 𝔟 𝔤 𝔣.  𝔣 : 𝔟  𝔞; 𝔤 : 𝔟  𝔞  
    E ε. ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "
    and "A I. tm_cf_discrete α I A   P π. π : A >CF. P : I ↦↦Cα "
  shows "cat_small_cocomplete α "
proof-
  have "E ε. ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα op_cat "
    if "𝔣 : 𝔟  𝔞" and "𝔤 : 𝔟  𝔞" for 𝔞 𝔟 𝔤 𝔣
  proof-
    from assms(1)[OF that] obtain ε E where 
      ε: "ε : (𝔞,𝔟,𝔤,𝔣) >CF.coeq E : ↑↑2C ↦↦Cα "
      by clarsimp
    interpret ε: is_cat_coequalizer α 𝔞 𝔟 𝔤 𝔣  E ε by (rule ε)
    from ε.is_cat_equalizer_op show ?thesis by auto
  qed
  moreover have "P π. π : P <CF. A : I ↦↦Cα op_cat "
    if "tm_cf_discrete α I A (op_cat )" for A I
  proof-
    interpret tm_cf_discrete α I A ‹op_cat  by (rule that)
    from assms(2)[OF tm_cf_discrete_op[unfolded cat_op_simps]] obtain P π 
      where π: "π : A >CF. P : I ↦↦Cα "
      by auto
    interpret π: is_cat_obj_coprod α I A  P π by (rule π)
    from π.is_cat_obj_prod_op show ?thesis by auto
  qed
  ultimately interpret cat_small_complete α ‹op_cat 
    by 
      (
        rule category.cat_small_complete_if_eq_and_obj_prod[
          OF category_op, unfolded cat_op_simps
          ]
      )
  show ?thesis by (rule cat_small_cocomplete_op[unfolded cat_op_simps])
qed



subsection‹Finite-complete category›

locale cat_finite_complete = category α  for α  + 
  assumes cat_finite_complete: 
    "𝔉 𝔍.  finite_category α 𝔍; 𝔉 : 𝔍 ↦↦Cα    
      u r. u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "

locale cat_finite_cocomplete = category α  for α  + 
  assumes cat_finite_cocomplete: 
    "𝔉 𝔍.  finite_category α 𝔍; 𝔉 : 𝔍 ↦↦Cα    
      u r. u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα "


text‹Rules.›

mk_ide rf cat_finite_complete_def[unfolded cat_finite_complete_axioms_def]
  |intro cat_finite_completeI|
  |dest cat_finite_completeD[dest]|
  |elim cat_finite_completeE[elim]|

lemma cat_finite_completeE'[elim]:
  assumes "cat_finite_complete α " 
    and "finite_category α 𝔍" 
    and "𝔉 : 𝔍 ↦↦Cα "
  obtains u r where "u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα "
  using assms by auto

mk_ide rf cat_finite_cocomplete_def[unfolded cat_finite_cocomplete_axioms_def]
  |intro cat_finite_cocompleteI|
  |dest cat_finite_cocompleteD[dest]|
  |elim cat_finite_cocompleteE[elim]|

lemma cat_finite_cocompleteE'[elim]:
  assumes "cat_finite_cocomplete α " 
    and "finite_category α 𝔍" 
    and "𝔉 : 𝔍 ↦↦Cα "
  obtains u r where "u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα "
  using assms by auto


text‹Elementary properties.›

sublocale cat_small_complete  cat_finite_complete
proof(intro cat_finite_completeI)
  fix 𝔉 𝔍 assume prems: "finite_category α 𝔍" "𝔉 : 𝔍 ↦↦Cα "
  interpret 𝔉: is_functor α 𝔍  𝔉 by (rule prems(2))
  from cat_small_complete_axioms show "u r. u : r <CF.lim 𝔉 : 𝔍 ↦↦Cα " 
    by (auto intro: 𝔉.cf_is_tm_functor_if_HomDom_finite_category[OF prems(1)])
qed (auto intro: cat_cs_intros)

sublocale cat_small_cocomplete  cat_finite_cocomplete
proof(intro cat_finite_cocompleteI)
  fix 𝔉 𝔍 assume prems: "finite_category α 𝔍" "𝔉 : 𝔍 ↦↦Cα "
  interpret 𝔉: is_functor α 𝔍  𝔉 by (rule prems(2))
  from cat_small_cocomplete_axioms show "u r. u : 𝔉 >CF.colim r : 𝔍 ↦↦Cα " 
    by (auto intro: 𝔉.cf_is_tm_functor_if_HomDom_finite_category[OF prems(1)])
qed (auto intro: cat_cs_intros)



subsection‹Discrete functor with tiny maps to the category Set›

lemma (in 𝒵) tm_cf_discrete_cat_Set_if_VLambda_in_Vset:
  assumes "VLambda I F  Vset α"
  shows "tm_cf_discrete α I F (cat_Set α)"
proof(intro tm_cf_discreteI)
  from assms have vrange_F_in_Vset: " (VLambda I F)  Vset α"
    by (auto intro: vrange_in_VsetI)
  show "(λiI. cat_Set αCIdF i)  Vset α"
  proof(rule vbrelation.vbrelation_Limit_in_VsetI)
    from assms show "𝒟 (λiI. cat_Set αCIdF i)  Vset α"
      by (metis vdomain_VLambda vdomain_in_VsetI)
    define Q where
      "Q i =
        (
          if i = 0
          then VPow ((iI. F i) × (iI. F i)) 
          else set (F ` elts I)
        )" 
      for i :: V
    have " (λiI. cat_Set αCIdF i)  (i set {0, 1, 2}. Q i)"
    proof(intro vsubsetI, unfold cat_Set_components)
      fix y assume "y   (λiI. VLambda (Vset α) id_SetF i)"
      then obtain i where i: "i  I" 
        and y_def: "y = VLambda (Vset α) id_SetF i" 
        by auto
      from i have "F i   (VLambda I F)" by auto
      with vrange_F_in_Vset have "F i  Vset α" by auto
      then have y_def: "y = id_Set (F i)" unfolding y_def by auto
      show "y  (iset {0, 1, 2}. Q i)"
        unfolding y_def
      proof(intro vproductI, unfold Ball_def; (intro allI impI)?)
        show "𝒟 (id_Rel (F i)) = set {0, 1, 2}"  
          by (simp add: id_Rel_def incl_Rel_def three nat_omega_simps)
        fix j assume "j  set {0, 1, 2}"
        then consider j = 0 | j = 1 | j = 2 by auto
        then show "id_Rel (F i)j  Q j"
        proof cases
          case 1
          from i show ?thesis
            unfolding 1
            by 
              (
                subst arr_field_simps(1)[symmetric], 
                unfold id_Rel_components Q_def
              )
              force
        next
          case 2
          from i show ?thesis
            unfolding 2
            by 
              (
                subst arr_field_simps(2)[symmetric], 
                unfold id_Rel_components Q_def
              ) 
              auto
        next
          case 3
          from i show ?thesis
            unfolding 3
            by 
              (
                subst arr_field_simps(3)[symmetric], 
                unfold id_Rel_components Q_def
              ) 
              auto
        qed
      qed (auto simp: id_Rel_def cat_Set_cs_intros)
    qed
    moreover have "(i set {0, 1, 2}. Q i)  Vset α"
    proof(rule Limit_vproduct_in_VsetI)
      show "set {0, 1, 2}  Vset α" unfolding three[symmetric] by simp
      from assms have "VPow ((iI. F i) × (iI. F i))  Vset α"
        by 
          (
            intro 
              Limit_VPow_in_VsetI 
              Limit_vtimes_in_VsetI 
              Limit_vifunion_in_Vset_if_VLambda_in_VsetI
          )
          auto
      then show "Q i  Vset α" if "i  set {0, 1, 2}" for i
        using that vrange_VLambda
        by (auto intro!: vrange_F_in_Vset simp: Q_def nat_omega_simps)
    qed auto
    ultimately show " (λiI. cat_Set αCIdF i)  Vset α"
      by (meson vsubset_in_VsetI) 
  qed auto
  fix i assume prems: "i  I"
  from assms have " (VLambda I F)  Vset α" by (auto simp: vrange_in_VsetI)
  moreover from prems have "F i   (VLambda I F)" by auto
  ultimately show "F i  cat_Set αObj" unfolding cat_Set_components by auto    
qed (cs_concl cs_intro: cat_cs_intros assms)+



subsection‹Product cone for the category Set›


subsubsection‹Definition and elementary properties›

definition ntcf_Set_obj_prod :: "V  V  (V  V)  V"
  where "ntcf_Set_obj_prod α I F = ntcf_obj_prod_base 
    (cat_Set α) I F (iI. F i) (λi. vprojection_arrow I F i)"


text‹Components.›

lemma ntcf_Set_obj_prod_components:
  shows "ntcf_Set_obj_prod α I FNTMap =
    (λi:C IObj. vprojection_arrow I F i)"
    and "ntcf_Set_obj_prod α I FNTDom =
    cf_const (:C I) (cat_Set α) (iI. F i)"
    and "ntcf_Set_obj_prod α I FNTCod = :→: I F (cat_Set α)"
    and "ntcf_Set_obj_prod α I FNTDGDom = :C I"
    and "ntcf_Set_obj_prod α I FNTDGCod = cat_Set α"
  unfolding ntcf_Set_obj_prod_def ntcf_obj_prod_base_components by simp_all


subsubsection‹Natural transformation map›

mk_VLambda ntcf_Set_obj_prod_components(1)
  |vsv ntcf_Set_obj_prod_NTMap_vsv[cat_cs_intros]|
  |vdomain ntcf_Set_obj_prod_NTMap_vdomain[cat_cs_simps]|
  |app ntcf_Set_obj_prod_NTMap_app[cat_cs_simps]|


subsubsection‹Product cone for the category Set› is a universal cone›

lemma (in 𝒵) tm_cf_discrete_ntcf_obj_prod_base_is_cat_obj_prod:
  ―‹See Theorem 5.2 in Chapter Introduction in \cite{hungerford_algebra_2003}.›
  assumes "VLambda I F  Vset α"
  shows "ntcf_Set_obj_prod α I F : (iI. F i) <CF. F : I ↦↦Cα cat_Set α"
proof(intro is_cat_obj_prodI is_cat_limitI')

  interpret Set: tm_cf_discrete α I F ‹cat_Set α 
    by (rule tm_cf_discrete_cat_Set_if_VLambda_in_Vset[OF assms])

  let ?F = ‹ntcf_Set_obj_prod α I F

  show "cf_discrete α I F (cat_Set α)"
    by (auto simp: cat_small_discrete_cs_intros)
  show F_is_cat_cone: "?F :
    (iI. F i) <CF.cone :→: I F (cat_Set α) : :C I ↦↦Cα cat_Set α"
      unfolding ntcf_Set_obj_prod_def
  proof(rule Set.tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone)
    show "(iI. F i)  cat_Set αObj"
      unfolding cat_Set_components
      by 
        (
          intro 
            Limit_vproduct_in_Vset_if_VLambda_in_VsetI 
            Set.tm_cf_discrete_ObjMap_in_Vset
        ) 
        auto
  qed (intro vprojection_arrow_is_arr Set.tm_cf_discrete_ObjMap_in_Vset)

  interpret F: is_cat_cone 
    α iI. F i :C I ‹cat_Set α :→: I F (cat_Set α) ?F
    by (rule F_is_cat_cone)

  fix π' P' assume prems:
    "π' : P' <CF.cone :→: I F (cat_Set α) : :C I ↦↦Cα cat_Set α"

  let ?π'i = λi. π'NTMapi
  let ?up' = ‹cat_Set_obj_prod_up I F P' ?π'i

  interpret π': is_cat_cone α P' :C I ‹cat_Set α :→: I F (cat_Set α) π'
    by (rule prems(1))

  show "∃!f'.
    f' : P' cat_Set α (iI. F i) 
    π' = ?F NTCF ntcf_const (:C I) (cat_Set α) f'"
  proof(intro ex1I conjI; (elim conjE)?)
    show up': "?up' : P' cat_Set α (iI. F i)" 
    proof(rule cat_Set_obj_prod_up_cat_Set_is_arr)
      show "P'  Vset α" by (auto intro: cat_cs_intros cat_lim_cs_intros)
      fix i assume "i  I"
      then show "π'NTMapi : P' cat_Set α F i"
        by 
          (
            cs_concl 
              cs_simp: 
                the_cat_discrete_components(1) 
                cat_cs_simps cat_discrete_cs_simps 
              cs_intro: cat_cs_intros
          )
    qed (rule assms)

    then have P': "P'  Vset α" 
      by (auto intro: cat_cs_intros cat_lim_cs_intros)

    have π'i_i: "?π'i i : P' cat_Set α F i" if "i  I" for i
      using 
        π'.ntcf_NTMap_is_arr[unfolded the_cat_discrete_components(1), OF that]
        that
      by 
        (
          cs_prems cs_simp:
            cat_cs_simps cat_discrete_cs_simps the_cat_discrete_components(1)
        )
    from cat_Set_obj_prod_up_cat_Set_is_arr[OF P' assms(1) π'i_i] have π'i: 
      "cat_Set_obj_prod_up I F P' ?π'i : P' cat_Set α (iI. F i)". 

    show "π' = ?F NTCF ntcf_const (:C I) (cat_Set α) ?up'"
    proof(rule ntcf_eqI, rule π'.is_ntcf_axioms)

      from F_is_cat_cone π'i show 
        "?F NTCF ntcf_const (:C I) (cat_Set α) ?up' :
          cf_const (:C I) (cat_Set α) P' CF :→: I F (cat_Set α) : 
          :C I ↦↦Cα cat_Set α"
        by (cs_concl cs_intro: cat_cs_intros)

      have dom_lhs: "𝒟 (π'NTMap) = :C IObj"
        by (cs_concl cs_simp: cat_cs_simps)
      from F_is_cat_cone π'i have dom_rhs: 
        "𝒟 ((?F NTCF ntcf_const (:C I) (cat_Set α) ?up')NTMap) = :C IObj"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

      show "π'NTMap = (?F NTCF ntcf_const (:C I) (cat_Set α) ?up')NTMap"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
        fix i assume prems': "i  :C IObj"
        then have i: "i  I" unfolding the_cat_discrete_components by simp
        have [cat_cs_simps]: 
          "vprojection_arrow I F i Acat_Set α ?up' = π'NTMapi"
          by 
            (
              rule pdg_dghm_comp_dghm_proj_dghm_up[
                OF P' assms π'i_i i, symmetric
                ]
            ) 
            auto
        from π'i prems' show "π'NTMapi =
          (?F NTCF ntcf_const (:C I) (cat_Set α) ?up')NTMapi"
          by 
            (
              cs_concl 
                cs_simp: cat_cs_simps cat_Rel_cs_simps cs_intro: cat_cs_intros
            )
      qed (auto simp: cat_cs_intros)

    qed simp_all

    fix f' assume prems:
      "f' : P' cat_Set α (iI. F i)"
      "π' = ?F NTCF ntcf_const (:C I) (cat_Set α) f'"
    from prems(2) have π'_eq_F_f': "π'NTMapiArrVala = 
      (?F NTCF ntcf_const (:C I) (cat_Set α) f')NTMapiArrVala"
      if "i  I" and "a  P'" for i a
      by simp
    have [cat_Set_cs_simps]: "π'NTMapiArrVala = f'ArrValai"
      if "i  I" and "a  P'" for i a
      using 
        π'_eq_F_f'[OF that] 
        assms prems that 
        vprojection_arrow_is_arr[OF that(1) assms]
      by 
        (
          cs_prems
            cs_simp: 
              cat_Set_cs_simps 
              cat_cs_simps 
              vprojection_arrow_app 
              the_cat_discrete_components(1) 
            cs_intro: cat_Set_cs_intros cat_cs_intros
        )

    note f' = cat_Set_is_arrD[OF prems(1)]
    note up' = cat_Set_is_arrD[OF up']

    interpret f': arr_Set α f' by (rule f'(1))
    interpret u': arr_Set α (cat_Set_obj_prod_up I F P' (app (π'NTMap))) 
      by (rule up'(1))

    show "f' = ?up'"
    proof(rule arr_Set_eqI[of α])
      have dom_lhs: "𝒟 (f'ArrVal) = P'" 
        by (simp add: cat_Set_cs_simps cat_cs_simps f')
      have dom_rhs: 
        "𝒟 (cat_Set_obj_prod_up I F P' (app (π'NTMap))ArrVal) = P'"
        by (simp add: cat_Set_cs_simps cat_cs_simps up')
      show "f'ArrVal = cat_Set_obj_prod_up I F P' (app (π'NTMap))ArrVal"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
        fix a assume prems': "a  P'"
        from prems(1) prems' have "f'ArrVala  (iI. F i)"
          by (cs_concl cs_intro: cat_Set_cs_intros)
        note f'a = vproductD[OF this]
        from prems' have dom_rhs: 
          "𝒟 (cat_Set_obj_prod_up I F P' (app (π'NTMap))ArrVala) = I"
          by (cs_concl cs_simp: cat_Set_cs_simps)
        show "f'ArrVala =
          cat_Set_obj_prod_up I F P' (app (π'NTMap))ArrVala"
        proof(rule vsv_eqI, unfold f'a dom_rhs)
          fix i assume "i  I"
          with prems' show "f'ArrValai =
            cat_Set_obj_prod_up I F P' (app (π'NTMap))ArrValai"
            by (cs_concl cs_simp: cat_Set_cs_simps)
        qed (simp_all add: prems' f'a(1) cat_Set_obj_prod_up_ArrVal_app)
      qed auto
    qed (simp_all add: cat_Set_obj_prod_up_components f' up'(1))

  qed

qed



subsection‹Equalizer for the category Set›


subsubsection‹Definition and elementary properties›

abbreviation ntcf_Set_equalizer_map :: "V  V  V  V  V  V"
  where "ntcf_Set_equalizer_map α a g f i 
    (
      i = 𝔞PL ?
        incl_Set (vequalizer a g f) a :
        g Acat_Set α incl_Set (vequalizer a g f) a
    )"

definition ntcf_Set_equalizer :: "V  V  V  V  V  V"
  where "ntcf_Set_equalizer α a b g f = ntcf_equalizer_base
    (cat_Set α) a b g f (vequalizer a g f) (ntcf_Set_equalizer_map α a g f)"


text‹Components.›

context
  fixes a g f α :: V
begin

lemmas ntcf_Set_equalizer_components = 
  ntcf_equalizer_base_components[
    where=‹cat_Set α 
      and e=‹ntcf_Set_equalizer_map α a g f
      and E=‹vequalizer a g f
      and 𝔞=a and 𝔤=g and 𝔣=f,
      folded ntcf_Set_equalizer_def
      ]

end


subsubsection‹Natural transformation map›

mk_VLambda ntcf_Set_equalizer_components(1)
  |vsv ntcf_Set_equalizer_NTMap_vsv[cat_Set_cs_intros]|
  |vdomain ntcf_Set_equalizer_NTMap_vdomain[cat_Set_cs_simps]|
  |app ntcf_Set_equalizer_NTMap_app|

lemma ntcf_Set_equalizer_2_NTMap_app_𝔞[cat_Set_cs_simps]:
  assumes "x = 𝔞PL"
  shows 
    "ntcf_Set_equalizer α a b g fNTMapx =
      incl_Set (vequalizer a g f) a"
  unfolding assms the_cat_parallel_components(1) ntcf_Set_equalizer_components 
  by simp

lemma ntcf_Set_equalizer_2_NTMap_app_𝔟[cat_Set_cs_simps]:
  assumes "x = 𝔟PL"
  shows 
    "ntcf_Set_equalizer α a b g fNTMapx =
      g Acat_Set α incl_Set (vequalizer a g f) a"
  unfolding assms the_cat_parallel_components(1) ntcf_Set_equalizer_components
  using cat_PL_ineq
  by auto


subsubsection‹Equalizer for the category Set› is an equalizer›

lemma (in 𝒵) ntcf_Set_equalizer_2_is_cat_equalizer_2:
  assumes "𝔤 : 𝔞 cat_Set α 𝔟" and "𝔣 : 𝔞 cat_Set α 𝔟" 
  shows "ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 :
    vequalizer 𝔞 𝔤 𝔣 <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα cat_Set α"
proof(intro is_cat_equalizerI is_cat_equalizerI is_cat_limitI')
  
  let ?II_II = ↑↑→↑↑ (cat_Set α) 𝔞PL 𝔟PL 𝔤PL 𝔣PL 𝔞 𝔟 𝔤 𝔣
    and ?II = ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PL

  note 𝔤 = cat_Set_is_arrD[OF assms(1)]
  interpret 𝔤: arr_Set α 𝔤 
    rewrites "𝔤ArrDom = 𝔞" and "𝔤ArrCod = 𝔟"
    by (rule 𝔤(1)) (simp_all add: 𝔤)
  note 𝔣 = cat_Set_is_arrD[OF assms(2)]
  interpret 𝔣: arr_Set α 𝔣 
    rewrites "𝔣ArrDom = 𝔞" and "𝔣ArrCod = 𝔟"
    by (rule 𝔣(1)) (simp_all add: 𝔣)

  note [cat_Set_cs_intros] = 𝔤.arr_Set_ArrDom_in_Vset 𝔣.arr_Set_ArrCod_in_Vset
  
  let ?incl = ‹incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞

  show 𝔞𝔟𝔤𝔣_is_cat_cone: "ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 :
    vequalizer 𝔞 𝔤 𝔣 <CF.cone ?II_II : ?II ↦↦Cα cat_Set α"
    unfolding ntcf_Set_equalizer_def
  proof
    (
      intro 
        category.cat_ntcf_equalizer_base_is_cat_cone 
        category.cat_cf_parallel_cat_equalizer
    )
    from assms show 
      "(𝔟PL = 𝔞PL ? ?incl : 𝔤 Acat_Set α ?incl) :
        vequalizer 𝔞 𝔤 𝔣 cat_Set α 𝔟"
      by 
        (
          cs_concl 
            cs_simp: V_cs_simps 
            cs_intro: 
              V_cs_intros cat_Set_cs_intros cat_cs_intros 
              cat_PL_ineq[symmetric] 
        )
    show 
      "(𝔟PL = 𝔞PL ? ?incl : 𝔤 Acat_Set α ?incl) =
        𝔤 Acat_Set α (𝔞PL = 𝔞PL ? ?incl : 𝔤 Acat_Set α ?incl)"
      by 
        (
          cs_concl 
            cs_simp: V_cs_simps 
            cs_intro: 
              V_cs_intros cat_Set_cs_intros cat_cs_intros 
              cat_PL_ineq[symmetric] 
        )
    from assms show 
      "(𝔟PL = 𝔞PL ? ?incl : 𝔤 Acat_Set α ?incl) =
        𝔣 Acat_Set α (𝔞PL = 𝔞PL ? ?incl : 𝔤 Acat_Set α ?incl)"
      by 
        (
          cs_concl 
            cs_simp: V_cs_simps cat_Set_incl_Set_commute 
            cs_intro: V_cs_intros cat_PL_ineq[symmetric]
        )
  qed 
    (
      cs_concl 
        cs_intro: cat_cs_intros V_cs_intros cat_Set_cs_intros assms 
        cs_simp: V_cs_simps cat_cs_simps
    )+

  interpret 𝔞𝔟𝔤𝔣: is_cat_cone 
    α ‹vequalizer 𝔞 𝔤 𝔣 ?II ‹cat_Set α ?II_II ‹ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣
    by (rule 𝔞𝔟𝔤𝔣_is_cat_cone)

  show "∃!f'.
    f' : r' cat_Set α vequalizer 𝔞 𝔤 𝔣  
    u' = ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) f'"
    if "u' : r' <CF.cone ?II_II : ?II ↦↦Cα cat_Set α" for u' r'
  proof-
    
    interpret u': is_cat_cone α r' ?II ‹cat_Set α ?II_II u' by (rule that(1))

    have "𝔞PL  ↑↑C 𝔞PL 𝔟PL 𝔤PL 𝔣PLObj" 
      unfolding the_cat_parallel_components(1) by simp
    from 
      u'.ntcf_NTMap_is_arr[OF this] 
      𝔞𝔟𝔤𝔣.NTDom.HomCod.cat_cf_parallel_cat_equalizer[OF assms] 
    have u'_𝔞PL_is_arr: "u'NTMap𝔞PL : r' cat_Set α 𝔞"
      by (cs_prems_atom_step cat_cs_simps) 
        (
          cs_prems 
            cs_simp: cat_parallel_cs_simps 
            cs_intro: 
              cat_parallel_cs_intros 
              cat_cs_intros
              category.cat_cf_parallel_cat_equalizer
        )
    note u'_𝔞PL = cat_Set_is_arrD[OF u'_𝔞PL_is_arr]
    interpret u'_𝔞PL: arr_Set α u'NTMap𝔞PL by (rule u'_𝔞PL(1))

    have "𝔟PL  ?IIObj" 
      by (cs_concl cs_intro: cat_parallel_cs_intros)

    from 
      u'.ntcf_NTMap_is_arr[OF this] 
      𝔞𝔟𝔤𝔣.NTDom.HomCod.cat_cf_parallel_cat_equalizer[OF assms]
    have "u'NTMap𝔟PL : r' cat_Set α 𝔟"
      by 
        (
          cs_prems 
            cs_simp: cat_cs_simps cat_parallel_cs_simps 
            cs_intro: cat_parallel_cs_intros
        )

    note u'_𝔤u' = cat_cone_cf_par_eps_NTMap_app(1)[OF that(1) assms]
    
    define q where "q = [u'NTMap𝔞PLArrVal, r', vequalizer 𝔞 𝔤 𝔣]"

    have q_components[cat_Set_cs_simps]:  
      "qArrVal = u'NTMap𝔞PLArrVal" 
      "qArrDom = r'" 
      "qArrCod = vequalizer 𝔞 𝔤 𝔣"
      unfolding q_def arr_field_simps by (simp_all add: nat_omega_simps)

    from cat_cone_cf_par_eps_NTMap_app[OF that(1) assms] have 𝔤u'_eq_𝔣u':
      "(𝔤 Acat_Set α u'NTMap𝔞PL)ArrValx =
        (𝔣 Acat_Set α u'NTMap𝔞PL)ArrValx"
      for x 
      by simp

    show ?thesis
    proof(intro ex1I conjI; (elim conjE)?)

      have u'_NTMap_vrange: " (u'NTMap𝔞PLArrVal)  vequalizer 𝔞 𝔤 𝔣"
      proof(rule vsubsetI)
        fix y assume prems: "y   (u'NTMap𝔞PLArrVal)"
        then obtain x where x: "x  𝒟 (u'NTMap𝔞PLArrVal)" 
          and y_def: "y = u'NTMap𝔞PLArrValx"
          by (blast dest: u'_𝔞PL.ArrVal.vrange_atD)
        have x: "x  r'" 
          by (use x u'_𝔞PL_is_arr in cs_prems cs_simp: cat_cs_simps)          
        from 𝔤u'_eq_𝔣u'[of x] assms x u'_𝔞PL_is_arr have [simp]: 
          "𝔤ArrValu'NTMap𝔞PLArrValx =
            𝔣ArrValu'NTMap𝔞PLArrValx"
          by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        from prems u'_𝔞PL.arr_Set_ArrVal_vrange[unfolded u'_𝔞PL] show 
          "y  vequalizer 𝔞 𝔤 𝔣"
          by (intro vequalizerI, unfold y_def) auto
      qed

      show q_is_arr: "q : r' cat_Set α vequalizer 𝔞 𝔤 𝔣" 
      proof(intro cat_Set_is_arrI arr_SetI)
        show "qArrCod  Vset α" 
          by (auto simp: q_components intro: cat_cs_intros cat_lim_cs_intros)
      qed 
        (
          auto 
            simp: 
              cat_Set_cs_simps nat_omega_simps 
              u'_𝔞PL 
              q_def 
              u'_NTMap_vrange
              𝔞𝔟𝔤𝔣.NTDom.HomCod.cat_in_Obj_in_Vset
            intro: cat_cs_intros cat_lim_cs_intros
        )  

      from q_is_arr have 𝔞_q:  
        "incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞 Acat_Set α q : 
          r' cat_Set α 𝔞"
        by 
          (
            cs_concl
              cs_simp: cat_cs_simps
              cs_intro: V_cs_intros cat_cs_intros cat_Set_cs_intros
          )
      interpret arr_Set α ‹incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞 Acat_Set α q
        using 𝔞_q by (auto dest: cat_Set_is_arrD)

      show "u' = ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) q"
      proof(rule ntcf_eqI)
        from q_is_arr show 
          "ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) q :
            cf_const ?II (cat_Set α) r' CF 
            ?II_II : ?II ↦↦Cα cat_Set α"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        have dom_lhs: "𝒟 (u'NTMap) = ?IIObj" 
          by (cs_concl cs_simp: cat_cs_simps)
        from q_is_arr have dom_rhs:
          "𝒟 
            (
              (ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF 
              ntcf_const ?II (cat_Set α) q
            )NTMap) =  ?IIObj"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        show "u'NTMap =
          (
            ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) q
          )NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          show "vsv ((
            ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) q
            )NTMap)"
            by (cs_concl cs_intro: cat_cs_intros)
          fix a assume prems: "a  ?IIObj"
          have [symmetric, cat_Set_cs_simps]: 
            "u'NTMap𝔞PL = incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞 Acat_Set α q"
          proof(rule arr_Set_eqI[of α])
            from u'_𝔞PL_is_arr have dom_lhs: "𝒟 (u'NTMap𝔞PLArrVal) = r'"
              by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
            from 𝔞_q have dom_rhs: 
              "𝒟 ((incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞 Acat_Set α q)ArrVal) = r'"
              by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
            show "u'NTMap𝔞PLArrVal =
              (incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞 Acat_Set α q)ArrVal"
            proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
              fix a assume prems: "a  r'"
              with u'_NTMap_vrange dom_lhs u'_𝔞PL.ArrVal.vsv_vimageI2 have 
                "u'NTMap𝔞PLArrVala  vequalizer 𝔞 𝔤 𝔣"
                by blast
              with prems q_is_arr u'_𝔞PL_is_arr show 
                "u'NTMap𝔞PLArrVala =
                  (incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞 Acat_Set α q)ArrVala"
                by 
                  (
                    cs_concl 
                      cs_simp: cat_Set_cs_simps cat_cs_simps 
                      cs_intro: V_cs_intros cat_cs_intros cat_Set_cs_intros
                  )
            qed auto
          qed 
            (
              use u'_𝔞PL 𝔞_q in cs_concl cs_intro: cat_Set_is_arrD(1) cs_simp: cat_cs_simps
            )+
          from q_is_arr have u'_NTMap_app_I: "u'NTMap𝔞PL =
            (
              ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) q
            )NTMap𝔞PL"
            by 
              (
                cs_concl 
                  cs_intro: cat_cs_intros cat_parallel_cs_intros 
                  cs_simp: cat_Set_cs_simps cat_cs_simps V_cs_simps
              )
          from q_is_arr assms have u'_NTMap_app_sI: "u'NTMap𝔟PL =
            (
              ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) q
            )NTMap𝔟PL"
            by 
              (
                cs_concl 
                  cs_simp: cat_Set_cs_simps cat_cs_simps u'_𝔤u' 
                  cs_intro: 
                    V_cs_intros 
                    cat_cs_intros 
                    cat_Set_cs_intros 
                    cat_parallel_cs_intros
              )
          from prems consider a = 𝔞PL | a = 𝔟PL 
            by (elim the_cat_parallel_ObjE)
          then show 
            "u'NTMapa =
              (
                ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF
                ntcf_const ?II (cat_Set α) q
              )NTMapa"
            by cases (simp_all add: u'_NTMap_app_I u'_NTMap_app_sI)
        qed auto
      qed (simp_all add: u'.is_ntcf_axioms)
        
      fix f' assume prems:
        "f' : r' cat_Set α vequalizer 𝔞 𝔤 𝔣"
        "u' = ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF ntcf_const ?II (cat_Set α) f'"
      from prems(2) have u'_NTMap_app: 
        "u'NTMapx =
          (ntcf_Set_equalizer α 𝔞 𝔟 𝔤 𝔣 NTCF
          ntcf_const ?II (cat_Set α) f')NTMapx"
        for x
        by simp
      have u'_f': 
        "u'NTMap𝔞PL = incl_Set (vequalizer 𝔞 𝔤 𝔣) 𝔞 Acat_Set α f'"
        using u'_NTMap_app[of 𝔞PL] prems(1)
        by 
          (
            cs_prems 
              cs_simp: cat_cs_simps 
              cs_intro: cat_cs_intros cat_parallel_cs_intros
          )
          (cs_prems cs_simp: cat_Set_cs_simps cs_intro: cat_parallel_cs_intros)

      note f' = cat_Set_is_arrD[OF prems(1)]
      note q = cat_Set_is_arrD[OF q_is_arr]

      interpret f': arr_Set α f' using prems(1) by (auto dest: cat_Set_is_arrD)
      interpret q: arr_Set α q using q by (auto dest: cat_Set_is_arrD)

      show "f' = q"
      proof(rule arr_Set_eqI[of α])
        have dom_lhs: "𝒟 (f'ArrVal) = r'" by (simp add: cat_Set_cs_simps f')
        from q_is_arr have dom_rhs: "𝒟 (qArrVal) = r'" 
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_Set_cs_intros)
        show "f'ArrVal = qArrVal"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix i assume "i  r'"
          with prems(1) show "f'ArrVali = qArrVali"
            by 
              (
                cs_concl 
                  cs_simp: cat_Set_cs_simps cat_cs_simps q_components u'_f'
                  cs_intro: V_cs_intros cat_cs_intros cat_Set_cs_intros
              )
        qed auto
      qed 
        (
          use prems(1) q_is_arr in cs_concl cs_simp: cat_cs_simps cs_intro: q cat_Set_is_arrD
            ›
        )+
    qed
  qed

qed (auto intro: assms)



subsection‹The category Set› is small-complete›

lemma (in 𝒵) cat_small_complete_cat_Set: "cat_small_complete α (cat_Set α)"
  ―‹This lemma appears as a remark on page 113 in
\cite{mac_lane_categories_2010}.›
proof(rule category.cat_small_complete_if_eq_and_obj_prod)
  show "E ε. ε : E <CF.eq (𝔞,𝔟,𝔤,𝔣) : ↑↑2C ↦↦Cα cat_Set α"
    if "𝔣 : 𝔞 cat_Set α 𝔟" and "𝔤 : 𝔞 cat_Set α 𝔟" for 𝔞 𝔟 𝔤 𝔣
    using ntcf_Set_equalizer_2_is_cat_equalizer_2[OF that(2,1)] by auto
  show "P π. π : P <CF. A : I ↦↦Cα cat_Set α"
    if "tm_cf_discrete α I A (cat_Set α)" for A I
  proof(intro exI, rule tm_cf_discrete_ntcf_obj_prod_base_is_cat_obj_prod)
    interpret tm_cf_discrete α I A ‹cat_Set α by (rule that)
    show "VLambda I A  Vset α" by (rule tm_cf_discrete_ObjMap_in_Vset)
  qed
qed (rule category_cat_Set)

text‹\newpage›

end

Theory CZH_UCAT_Adjoints

(* Copyright 2021 (C) Mihails Milehins *)

section‹Adjoints›
theory CZH_UCAT_Adjoints
  imports 
    CZH_UCAT_Universal
    CZH_Elementary_Categories.CZH_ECAT_Yoneda
begin



subsection‹Background›

named_theorems adj_cs_simps
named_theorems adj_cs_intros
named_theorems adj_field_simps

definition AdjLeft :: V where [adj_field_simps]: "AdjLeft = 0"
definition AdjRight :: V where [adj_field_simps]: "AdjRight = 1"
definition AdjNT :: V where [adj_field_simps]: "AdjNT = 2"



subsection‹Definition and elementary properties›


text‹
See subsection 2.1 in \cite{bodo_categories_1970} or Chapter IV-1 in
\cite{mac_lane_categories_2010}.
›

locale is_cf_adjunction =
  𝒵 α +
  vfsequence Φ +
  L: category α  +
  R: category α 𝔇 +
  LR: is_functor α  𝔇 𝔉 +
  RL: is_functor α 𝔇  𝔊 +
  NT: is_iso_ntcf 
    α 
    ‹op_cat  ×C 𝔇 
    ‹cat_Set α 
    HomO.Cα𝔇(𝔉-,-) 
    HomO.Cα(-,𝔊-) 
    ΦAdjNT
    for α  𝔇 𝔉 𝔊 Φ +
  assumes cf_adj_length[adj_cs_simps]: "vcard Φ = 3"
    and cf_adj_AdjLeft[adj_cs_simps]: "ΦAdjLeft = 𝔉"
    and cf_adj_AdjRight[adj_cs_simps]: "ΦAdjRight = 𝔊"

syntax "_is_cf_adjunction" :: "V  V  V  V  V  V  bool"
  ((_ : _ CF _ : _ ⇌⇌Cı _) [51, 51, 51, 51, 51] 51)
translations "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"  
  "CONST is_cf_adjunction α  𝔇 𝔉 𝔊 Φ"

lemmas [adj_cs_simps] = 
  is_cf_adjunction.cf_adj_length
  is_cf_adjunction.cf_adj_AdjLeft
  is_cf_adjunction.cf_adj_AdjRight


text‹Components.›

lemma cf_adjunction_components[adj_cs_simps]:
  "[𝔉, 𝔊, φ]AdjLeft = 𝔉"
  "[𝔉, 𝔊, φ]AdjRight = 𝔊"
  "[𝔉, 𝔊, φ]AdjNT = φ"
  unfolding AdjLeft_def AdjRight_def AdjNT_def 
  by (simp_all add: nat_omega_simps)


text‹Rules.›

lemma (in is_cf_adjunction) is_cf_adjunction_axioms'[adj_cs_intros]:
  assumes "α' = α" and "ℭ' = " and "𝔇' = 𝔇" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
  shows "Φ : 𝔉' CF 𝔊' : ℭ' ⇌⇌Cα' 𝔇'"  
  unfolding assms by (rule is_cf_adjunction_axioms)

lemmas (in is_cf_adjunction) [adj_cs_intros] = is_cf_adjunction_axioms

mk_ide rf is_cf_adjunction_def[unfolded is_cf_adjunction_axioms_def]
  |intro is_cf_adjunctionI|
  |dest is_cf_adjunctionD[dest]|
  |elim is_cf_adjunctionE[elim]|

lemmas [adj_cs_intros] = is_cf_adjunctionD(3-6)

lemma (in is_cf_adjunction) cf_adj_is_iso_ntcf':
  assumes "𝔉' = HomO.Cα𝔇(𝔉-,-)"
    and "𝔊' = HomO.Cα(-,𝔊-)"
    and "𝔄' = op_cat  ×C 𝔇"
    and "𝔅' = cat_Set α"
  shows "ΦAdjNT : 𝔉' CF.iso 𝔊' : 𝔄' ↦↦Cα 𝔅'"
  unfolding assms by (auto intro: cat_cs_intros)

lemmas [adj_cs_intros] = is_cf_adjunction.cf_adj_is_iso_ntcf'

lemma cf_adj_eqI:
  assumes "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "Φ' : 𝔉' CF 𝔊' : ℭ' ⇌⇌Cα 𝔇'"
    and " = ℭ'"
    and "𝔇 = 𝔇'"
    and "𝔉 = 𝔉'"
    and "𝔊 = 𝔊'"
    and "ΦAdjNT = Φ'AdjNT"
  shows "Φ = Φ'"
proof-
  interpret Φ: is_cf_adjunction α  𝔇 𝔉 𝔊 Φ by (rule assms(1))
  interpret Φ': is_cf_adjunction α ℭ' 𝔇' 𝔉' 𝔊' Φ' by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "𝒟 Φ = 3" by (cs_concl cs_simp: V_cs_simps adj_cs_simps)
    show "𝒟 Φ = 𝒟 Φ'" by (cs_concl cs_simp: V_cs_simps adj_cs_simps dom)
    from assms(4-7) have sup: 
      "ΦAdjLeft = Φ'AdjLeft" 
      "ΦAdjRight = Φ'AdjRight" 
      "ΦAdjNT = Φ'AdjNT"  
      by (simp_all add: adj_cs_simps)
    show "a  𝒟 Φ  Φa = Φ'a" for a 
      by (unfold dom, elim_in_numeral, insert sup) 
        (auto simp: adj_field_simps)
  qed (auto simp: Φ.L.vsv_axioms Φ'.vsv_axioms)
qed



subsection‹Opposite adjunction›


subsubsection‹Definition and elementary properties›


text‹
The following definition has the desired properties of the operation
of taking an opposite of an adjunction but helps to avoid dealing
with isomorphisms that arise in certain applications if the conventional
operation of taking the opposite is used instead.
›

abbreviation op_cf_adj_nt :: "V  V  V  V"
  where "op_cf_adj_nt  𝔇 φ  inv_ntcf (bnt_flip (op_cat ) 𝔇 φ)"

definition op_cf_adj :: "V  V"
  where "op_cf_adj Φ =
    [
      op_cf (ΦAdjRight),
      op_cf (ΦAdjLeft),
      op_cf_adj_nt (ΦAdjLeftHomDom) (ΦAdjLeftHomCod) (ΦAdjNT)
    ]"

lemma op_cf_adj_components:
  shows "op_cf_adj ΦAdjLeft = op_cf (ΦAdjRight)"
    and "op_cf_adj ΦAdjRight = op_cf (ΦAdjLeft)"
    and "op_cf_adj ΦAdjNT = 
      op_cf_adj_nt (ΦAdjLeftHomDom) (ΦAdjLeftHomCod) (ΦAdjNT)"
  unfolding op_cf_adj_def adj_field_simps by (simp_all add: nat_omega_simps)

lemma (in is_cf_adjunction) op_cf_adj_components:
  shows "op_cf_adj ΦAdjLeft = op_cf 𝔊"
    and "op_cf_adj ΦAdjRight = op_cf 𝔉"
    and "op_cf_adj ΦAdjNT = inv_ntcf (bnt_flip (op_cat ) 𝔇 (ΦAdjNT))"
  unfolding op_cf_adj_components by (simp_all add: cat_cs_simps adj_cs_simps)

lemmas [cat_op_simps] = is_cf_adjunction.op_cf_adj_components


text‹The opposite adjunction is an adjunction.›

lemma (in is_cf_adjunction) is_cf_adjunction_op:
  ―‹See comments in subsection 2.1 in \cite{bodo_categories_1970}.›
  "op_cf_adj Φ : op_cf 𝔊 CF op_cf 𝔉 : op_cat 𝔇 ⇌⇌Cα op_cat "
proof(intro is_cf_adjunctionI, unfold cat_op_simps, unfold op_cf_adj_components)
  show "vfsequence (op_cf_adj Φ)" unfolding op_cf_adj_def by simp
  show "vcard (op_cf_adj Φ) = 3"
    unfolding op_cf_adj_def by (simp add: nat_omega_simps)
  note adj = is_cf_adjunctionD[OF is_cf_adjunction_axioms]
  from adj have f_φ: "bnt_flip (op_cat ) 𝔇 (ΦAdjNT) :
    HomO.Cαop_cat 𝔇(-,op_cf 𝔉-) CF.iso HomO.Cαop_cat (op_cf 𝔊-,-) :
    𝔇 ×C op_cat  ↦↦Cα cat_Set α"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros)
  show "op_cf_adj_nt  𝔇 (ΦAdjNT) :
    HomO.Cαop_cat (op_cf 𝔊-,-) CF.iso HomO.Cαop_cat 𝔇(-,op_cf 𝔉-) :
    𝔇 ×C op_cat  ↦↦Cα cat_Set α"
    by (rule CZH_ECAT_NTCF.iso_ntcf_is_arr_isomorphism(1)[OF f_φ])
qed (auto intro: cat_cs_intros cat_op_intros)

lemmas is_cf_adjunction_op = 
  is_cf_adjunction.is_cf_adjunction_op

lemma (in is_cf_adjunction) is_cf_adjunction_op'[cat_op_intros]:
  assumes "𝔊' = op_cf 𝔊"
    and "𝔉' = op_cf 𝔉"
    and "𝔇' = op_cat 𝔇"
    and "ℭ' = op_cat "
  shows "op_cf_adj Φ : 𝔊' CF 𝔉' : 𝔇' ⇌⇌Cα ℭ'"
  unfolding assms by (rule is_cf_adjunction_op)

lemmas [cat_op_intros] = is_cf_adjunction.is_cf_adjunction_op'


text‹The operation of taking the opposite adjunction is an involution.›

lemma (in is_cf_adjunction) cf_adjunction_op_cf_adj_op_cf_adj[cat_op_simps]:
  "op_cf_adj (op_cf_adj Φ) = Φ"
proof(rule cf_adj_eqI)
  show Φ': "op_cf_adj (op_cf_adj Φ) : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
  proof(intro is_cf_adjunctionI)
    show "vfsequence (op_cf_adj (op_cf_adj Φ))" unfolding op_cf_adj_def by simp
    from is_cf_adjunction_axioms show "op_cf_adj (op_cf_adj Φ)AdjNT : 
      HomO.Cα𝔇(𝔉-,-) CF.iso HomO.Cα(-,𝔊-) : 
      op_cat  ×C 𝔇 ↦↦Cα cat_Set α"
      by
        (
          cs_concl cs_ist_simple
            cs_intro: cat_cs_intros cat_op_intros adj_cs_intros
            cs_simp: cat_cs_simps cat_op_simps
        )
    show "vcard (op_cf_adj (op_cf_adj Φ)) = 3"
      unfolding op_cf_adj_def by (simp add: nat_omega_simps)
    from is_cf_adjunction_axioms show "op_cf_adj (op_cf_adj Φ)AdjLeft = 𝔉"
      by (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)
    from is_cf_adjunction_axioms show "op_cf_adj (op_cf_adj Φ)AdjRight = 𝔊"
      by (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)
  qed (auto intro: cat_cs_intros)
  interpret Φ': is_cf_adjunction α  𝔇 𝔉 𝔊 ‹op_cf_adj (op_cf_adj Φ) 
    by (rule Φ')
  show "op_cf_adj (op_cf_adj Φ)AdjNT = ΦAdjNT"
  proof(rule ntcf_eqI)
    show op_op_Φ:
      "op_cf_adj (op_cf_adj Φ)AdjNT :
        HomO.Cα𝔇(𝔉-,-) CF HomO.Cα(-,𝔊-) :
        op_cat  ×C 𝔇 ↦↦Cα cat_Set α"
      by (rule Φ'.NT.is_ntcf_axioms)
    show Φ: "ΦAdjNT :
      HomO.Cα𝔇(𝔉-,-) CF HomO.Cα(-,𝔊-) : 
      op_cat  ×C 𝔇 ↦↦Cα cat_Set α"
      by (rule NT.is_ntcf_axioms)
    from op_op_Φ have dom_lhs:
      "𝒟 (op_cf_adj (op_cf_adj Φ)AdjNTNTMap) = (op_cat  ×C 𝔇)Obj"
      by (cs_concl cs_simp: cat_cs_simps)
    show "op_cf_adj (op_cf_adj Φ)AdjNTNTMap = ΦAdjNTNTMap"
    proof(rule vsv_eqI, unfold NT.ntcf_NTMap_vdomain dom_lhs)
      fix cd assume prems: "cd  (op_cat  ×C 𝔇)Obj"
      then obtain c d 
        where cd_def: "cd = [c, d]"
          and c: "c  op_cat Obj"
          and d: "d  𝔇Obj"
        by (elim cat_prod_2_ObjE[OF L.category_op R.category_axioms prems])
      from is_cf_adjunction_axioms c d L.category_axioms R.category_axioms Φ 
      show 
        "op_cf_adj (op_cf_adj Φ)AdjNTNTMapcd = ΦAdjNTNTMapcd"
        unfolding cd_def cat_op_simps
        by 
          (
            cs_concl
              cs_intro: 
                cat_arrow_cs_intros 
                ntcf_cs_intros 
                adj_cs_intros 
                cat_op_intros 
                cat_cs_intros 
                cat_prod_cs_intros 
             cs_simp: cat_cs_simps cat_op_simps
         )
    qed (auto intro: inv_ntcf_NTMap_vsv)
  qed simp_all
qed (auto intro: adj_cs_intros)

lemmas [cat_op_simps] = is_cf_adjunction.cf_adjunction_op_cf_adj_op_cf_adj



subsubsection‹Alternative form of the naturality condition›


text‹
The lemmas in this subsection are based on the comments on page 81 in 
\cite{mac_lane_categories_2010}.
›

lemma (in is_cf_adjunction) cf_adj_Comp_commute_RL:
  assumes "x  Obj" 
    and "f : 𝔉ObjMapx 𝔇 a"
    and "k : a 𝔇 a'"
  shows 
    "𝔊ArrMapk A (ΦAdjNTNTMapx, a)ArrValf =
      (ΦAdjNTNTMapx, a')ArrValk A𝔇 f"
proof-
  from 
    assms 
    is_cf_adjunction_axioms 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have φ_x_a: "ΦAdjNTNTMapx, a :
    Hom 𝔇 (𝔉ObjMapx) a cat_Set α Hom  x (𝔊ObjMapa)"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  note φ_x_a_f = 
    cat_Set_ArrVal_app_vrange[OF φ_x_a, unfolded in_Hom_iff, OF assms(2)]
  from 
    is_cf_adjunction_axioms assms 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have φ_x_a': 
    "ΦAdjNTNTMapx, a' :
      Hom 𝔇 (𝔉ObjMapx) a' cat_Set α Hom  x (𝔊ObjMapa')"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  from is_cf_adjunction_axioms this assms have x_k:
    "[CIdx, k] : [x, a] op_cat  ×C 𝔇 [x, a']"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  from 
    NT.ntcf_Comp_commute[OF this] is_cf_adjunction_axioms assms 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have
    "ΦAdjNTNTMapx, a' Acat_Set α cf_hom 𝔇 [𝔇CId𝔉ObjMapx, k] =
      cf_hom  [CIdx, 𝔊ArrMapk] Acat_Set α ΦAdjNTNTMapx, a"
    (is ?lhs = ?rhs)
    by (*slow*)
      (
        cs_prems cs_ist_simple
          cs_simp: cat_cs_simps
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  moreover from 
    is_cf_adjunction_axioms assms φ_x_a' 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have
    "?lhsArrValf = (ΦAdjNTNTMapx, a')ArrValk A𝔇 f"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  moreover from 
    is_cf_adjunction_axioms assms φ_x_a_f 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have
    "?rhsArrValf = 𝔊ArrMapk A (ΦAdjNTNTMapx, a)ArrValf"
    by 
      (
        cs_concl
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  ultimately show ?thesis by simp
qed

lemma (in is_cf_adjunction) cf_adj_Comp_commute_LR:
  assumes "x  Obj" 
    and "f : 𝔉ObjMapx 𝔇 a"
    and "h : x'  x"
  shows
    "(ΦAdjNTNTMapx, a)ArrValf A h =
      (ΦAdjNTNTMapx', a)ArrValf A𝔇 𝔉ArrMaph"
proof-
  from 
    is_cf_adjunction_axioms assms 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have φ_x_a: "ΦAdjNTNTMapx, a :
    Hom 𝔇 (𝔉ObjMapx) a cat_Set α Hom  x (𝔊ObjMapa)"
    by 
      (
        cs_concl
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  note φ_x_a_f = 
    cat_Set_ArrVal_app_vrange[OF φ_x_a, unfolded in_Hom_iff, OF assms(2)]
  from is_cf_adjunction_axioms assms have
    "[h, 𝔇CIda] : [x, a] op_cat  ×C 𝔇 [x', a]"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  from 
    NT.ntcf_Comp_commute[OF this] is_cf_adjunction_axioms assms 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have
    "ΦAdjNTNTMapx', a Acat_Set α cf_hom 𝔇 [𝔉ArrMaph, 𝔇CIda] =
      cf_hom  [h, CId𝔊ObjMapa] Acat_Set α ΦAdjNTNTMapx, a"
    (is ?lhs = ?rhs)
    by (*slow*)
      (
        cs_prems
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )  
  moreover from 
    is_cf_adjunction_axioms assms 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have
    "?lhsArrValf = (ΦAdjNTNTMapx', a)ArrValf A𝔇 𝔉ArrMaph"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  moreover from 
    is_cf_adjunction_axioms assms φ_x_a_f 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have 
    "?rhsArrValf = (ΦAdjNTNTMapx, a)ArrValf A h"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  ultimately show ?thesis by simp
qed



subsection‹Unit›


subsubsection‹Definition and elementary properties›


text‹See Chapter IV-1 in \cite{mac_lane_categories_2010}.›

definition cf_adjunction_unit :: "V  V" (ηC)
  where "ηC Φ =
    [
      (
        λxΦAdjLeftHomDomObj.
          (ΦAdjNTNTMapx, ΦAdjLeftObjMapx)ArrVal
            ΦAdjLeftHomCodCIdΦAdjLeftObjMapx
          
      ),
      cf_id (ΦAdjLeftHomDom),
      (ΦAdjRight) CF (ΦAdjLeft),
      ΦAdjLeftHomDom,
      ΦAdjLeftHomDom
    ]"


text‹Components.›

lemma cf_adjunction_unit_components:
  shows "ηC ΦNTMap =
    (
      λxΦAdjLeftHomDomObj.
        (ΦAdjNTNTMapx, ΦAdjLeftObjMapx)ArrVal
          ΦAdjLeftHomCodCIdΦAdjLeftObjMapx
        
    )"
    and "ηC ΦNTDom = cf_id (ΦAdjLeftHomDom)"
    and "ηC ΦNTCod = (ΦAdjRight) CF (ΦAdjLeft)"
    and "ηC ΦNTDGDom = ΦAdjLeftHomDom"
    and "ηC ΦNTDGCod = ΦAdjLeftHomDom"
  unfolding cf_adjunction_unit_def nt_field_simps 
  by (simp_all add: nat_omega_simps)

context is_cf_adjunction
begin

lemma cf_adjunction_unit_components':
  shows "ηC ΦNTMap =
    (
      λxObj.
        (ΦAdjNTNTMapx, 𝔉ObjMapx)ArrVal𝔇CId𝔉ObjMapx
    )"
    and "ηC ΦNTDom = cf_id "
    and "ηC ΦNTCod = 𝔊 CF 𝔉"
    and "ηC ΦNTDGDom = "
    and "ηC ΦNTDGCod = "
  unfolding cf_adjunction_unit_components
  by (cs_concl cs_simp: cat_cs_simps adj_cs_simps)+

mk_VLambda cf_adjunction_unit_components'(1)
  |vdomain cf_adjunction_unit_NTMap_vdomain[adj_cs_simps]|
  |app cf_adjunction_unit_NTMap_app[adj_cs_simps]|

end

mk_VLambda cf_adjunction_unit_components(1)
  |vsv cf_adjunction_unit_NTMap_vsv[adj_cs_intros]|

lemmas [adj_cs_simps] = 
  is_cf_adjunction.cf_adjunction_unit_NTMap_vdomain
  is_cf_adjunction.cf_adjunction_unit_NTMap_app


subsubsection‹Natural transformation map›

lemma (in is_cf_adjunction) cf_adjunction_unit_NTMap_is_arr: 
  assumes "x  Obj"
  shows "ηC ΦNTMapx : x  𝔊ObjMap𝔉ObjMapx"
proof-
  from 
    is_cf_adjunction_axioms assms
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have φ_x_𝔉x: 
    "ΦAdjNTNTMapx, 𝔉ObjMapx :
      Hom 𝔇 (𝔉ObjMapx) (𝔉ObjMapx) cat_Set α 
      Hom  x (𝔊ObjMap𝔉ObjMapx)"
    by 
      (
        cs_concl 
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      ) 
  from is_cf_adjunction_axioms assms have CId_𝔉x: 
    "𝔇CId𝔉ObjMapx : 𝔉ObjMapx 𝔇 𝔉ObjMapx"
    by (cs_concl cs_simp: cs_intro: cat_cs_intros adj_cs_intros)   
  from 
    is_cf_adjunction_axioms 
    assms
    cat_Set_ArrVal_app_vrange[OF φ_x_𝔉x, unfolded in_Hom_iff, OF CId_𝔉x]
  show "ηC ΦNTMapx : x  𝔊ObjMap𝔉ObjMapx"
    by (cs_concl cs_simp: adj_cs_simps cs_intro: cat_cs_intros)
qed

lemma (in is_cf_adjunction) cf_adjunction_unit_NTMap_is_arr': 
  assumes "x  Obj"
    and "a = x"
    and "b = 𝔊ObjMap𝔉ObjMapx"
    and "ℭ' = "
  shows "ηC ΦNTMapx : x ℭ' b"
  using assms(1) unfolding assms(2-4) by (rule cf_adjunction_unit_NTMap_is_arr)

lemmas [adj_cs_intros] = is_cf_adjunction.cf_adjunction_unit_NTMap_is_arr'

lemma (in is_cf_adjunction) cf_adjunction_unit_NTMap_vrange: 
  " (ηC ΦNTMap)  Arr"
proof(rule vsv.vsv_vrange_vsubset, unfold cf_adjunction_unit_NTMap_vdomain)
  fix x assume prems: "x  Obj"
  from cf_adjunction_unit_NTMap_is_arr[OF prems] show "ηC ΦNTMapx  Arr"
    by auto
qed (auto intro: adj_cs_intros)


subsubsection‹Unit is a natural transformation›

lemma (in is_cf_adjunction) cf_adjunction_unit_is_ntcf:
  "ηC Φ : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
proof(intro is_ntcfI')
  show "vfsequence (ηC Φ)" unfolding cf_adjunction_unit_def by simp
  show "vcard (ηC Φ) = 5"
    unfolding cf_adjunction_unit_def by (simp add: nat_omega_simps)
  from is_cf_adjunction_axioms show "cf_id  :  ↦↦Cα "
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros adj_cs_intros)
  from is_cf_adjunction_axioms show "𝔊 CF 𝔉 :  ↦↦Cα "
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros adj_cs_intros)
  from is_cf_adjunction_axioms show "𝒟 (ηC ΦNTMap) = Obj"
    by (cs_concl cs_simp: adj_cs_simps cs_intro: cat_cs_intros)
  show "ηC ΦNTMapa : cf_id ObjMapa  (𝔊 CF 𝔉)ObjMapa"
    if "a  Obj" for a
    using is_cf_adjunction_axioms that 
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros adj_cs_intros)
  show
    "ηC ΦNTMapb A cf_id ArrMapf =
      (𝔊 CF 𝔉)ArrMapf A ηC ΦNTMapa"
    if "f : a  b" for a b f
    using is_cf_adjunction_axioms that
    by 
      (
        cs_concl 
          cs_simp: 
            cf_adj_Comp_commute_RL cf_adj_Comp_commute_LR 
            cat_cs_simps  
            adj_cs_simps 
          cs_intro: cat_cs_intros adj_cs_intros
      )
qed (auto simp: cf_adjunction_unit_components')

lemma (in is_cf_adjunction) cf_adjunction_unit_is_ntcf':
  assumes "𝔖 = cf_id "
    and "𝔖' = 𝔊 CF 𝔉"
    and "𝔄 = "
    and "𝔅 = "
  shows "ηC Φ : 𝔖 CF 𝔖' : 𝔄 ↦↦Cα 𝔅"
  unfolding assms by (rule cf_adjunction_unit_is_ntcf)

lemmas [adj_cs_intros] = is_cf_adjunction.cf_adjunction_unit_is_ntcf'


subsubsection‹Every component of a unit is a universal arrow›


text‹
The lemmas in this subsection are based on elements of the statement of 
Theorem 1 in Chapter IV-1 in \cite{mac_lane_categories_2010}.
›

lemma (in is_cf_adjunction) cf_adj_umap_of_unit:
  assumes "x  Obj" and "a  𝔇Obj"
  shows "ΦAdjNTNTMapx, a =
    umap_of 𝔊 x (𝔉ObjMapx) (ηC ΦNTMapx) a"
  (is ΦAdjNTNTMapx, a = ?uof_a)
proof-

  from 
    is_cf_adjunction_axioms assms 
    L.category_axioms R.category_axioms (*speedup*)
    L.category_op R.category_op (*speedup*)
  have φ_xa: "ΦAdjNTNTMapx, a :
    Hom 𝔇 (𝔉ObjMapx) a cat_Set α Hom  x (𝔊ObjMapa)"
    by
      (
        cs_concl
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
      )
  then have dom_lhs:
    "𝒟 ((ΦAdjNTNTMapx, a)ArrVal) = Hom 𝔇 (𝔉ObjMapx) a"
    by (cs_concl cs_simp: cat_cs_simps)
  from is_cf_adjunction_axioms assms have uof_a:
    "?uof_a : Hom 𝔇 (𝔉ObjMapx) a cat_Set α Hom  x (𝔊ObjMapa)"
    by (cs_concl cs_simp: cs_intro: cat_cs_intros adj_cs_intros)
  then have dom_rhs: "𝒟 (?uof_aArrVal) = Hom 𝔇 (𝔉ObjMapx) a"
    by (cs_concl cs_simp: cat_cs_simps)

  show ?thesis
  proof(rule arr_Set_eqI[of α])
    from φ_xa show arr_Set_φ_xa: "arr_Set α (ΦAdjNTNTMapx, a)"
      by (auto dest: cat_Set_is_arrD(1))
    from uof_a show arr_Set_uof_a: "arr_Set α ?uof_a" 
      by (auto dest: cat_Set_is_arrD(1))
    show "(ΦAdjNTNTMapx, a)ArrVal = ?uof_aArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
      fix g assume prems: "g : 𝔉ObjMapx 𝔇 a"
      from is_cf_adjunction_axioms assms prems show
        "(ΦAdjNTNTMapx, a)ArrValg = ?uof_aArrValg"
        by
          (
            cs_concl
              cs_simp:
                cf_adj_Comp_commute_RL
                adj_cs_simps
                cat_cs_simps
                cat_op_simps
                cat_prod_cs_simps
              cs_intro:
                adj_cs_intros
                ntcf_cs_intros
                cat_cs_intros
                cat_op_intros
                cat_prod_cs_intros
          )
    qed (use arr_Set_φ_xa arr_Set_uof_a in auto)
  
  qed (use φ_xa uof_a in cs_concl cs_simp: cat_cs_simps)+

qed

lemma (in is_cf_adjunction) cf_adj_umap_of_unit':
  assumes "x  Obj" 
    and "a  𝔇Obj"
    and "η = ηC ΦNTMapx"
    and "𝔉x = 𝔉ObjMapx"
  shows "ΦAdjNTNTMapx, a = umap_of 𝔊 x 𝔉x η a"
  using assms(1,2) unfolding assms(3,4) by (rule cf_adj_umap_of_unit)

lemma (in is_cf_adjunction) cf_adjunction_unit_component_is_ua_of:
  assumes "x  Obj"
  shows "universal_arrow_of 𝔊 x (𝔉ObjMapx) (ηC ΦNTMapx)"
    (is ‹universal_arrow_of 𝔊 x (𝔉ObjMapx) ?ηx)
proof(rule RL.cf_ua_of_if_ntcf_ua_of_is_iso_ntcf)
  from is_cf_adjunction_axioms assms show "𝔉ObjMapx  𝔇Obj"
    by (cs_concl cs_intro: cat_cs_intros adj_cs_intros)
  from is_cf_adjunction_axioms assms show 
    "ηC ΦNTMapx : x  𝔊ObjMap𝔉ObjMapx"
    by (cs_concl cs_simp: cs_intro: cat_cs_intros adj_cs_intros)
  show 
    "ntcf_ua_of α 𝔊 x (𝔉ObjMapx) (ηC ΦNTMapx) :
      HomO.Cα𝔇(𝔉ObjMapx,-) CF.iso HomO.Cα(x,-) CF 𝔊 :
      𝔇 ↦↦Cα cat_Set α"
    (is ?ntcf_ua_of : ?H𝔉 CF.iso ?H𝔊 : 𝔇 ↦↦Cα cat_Set α)
  proof(rule is_iso_ntcfI)
    from is_cf_adjunction_axioms assms show 
      "?ntcf_ua_of : ?H𝔉 CF ?H𝔊 : 𝔇 ↦↦Cα cat_Set α"
      by (intro RL.cf_ntcf_ua_of_is_ntcf) 
        (cs_concl cs_simp: cs_intro: cat_cs_intros adj_cs_intros)+
    fix a assume prems: "a  𝔇Obj"
    from assms prems have 
      "ΦAdjNTNTMapx, a = umap_of 𝔊 x (𝔉ObjMapx) ?ηx a"
      (is ΦAdjNTNTMapx, a = ?uof_a)
      by (rule cf_adj_umap_of_unit)
    from assms prems L.category_axioms R.category_axioms have
      "[x, a]  (op_cat  ×C 𝔇)Obj"
      by (cs_concl cs_simp: cs_intro:  cat_op_intros cat_prod_cs_intros)
    from 
      NT.iso_ntcf_is_arr_isomorphism[
        OF this, unfolded cf_adj_umap_of_unit[OF assms prems]
        ]
      is_cf_adjunction_axioms assms prems
      L.category_axioms R.category_axioms
    have "?uof_a :
      Hom 𝔇 (𝔉ObjMapx) a isocat_Set α Hom  x (𝔊ObjMapa)"
      by 
        (
          cs_prems 
            cs_simp: cat_cs_simps 
            cs_intro: 
              cat_cs_intros cat_op_intros adj_cs_intros cat_prod_cs_intros
        )
    with is_cf_adjunction_axioms assms prems show 
      "?ntcf_ua_ofNTMapa : ?H𝔉ObjMapa isocat_Set α ?H𝔊ObjMapa"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps 
            cs_intro: cat_cs_intros cat_op_intros adj_cs_intros
        )
  qed
qed



subsection‹Counit›


subsubsection‹Definition and elementary properties›

definition cf_adjunction_counit :: "V  V" (εC)
  where "εC Φ =
    [
      (
        λxΦAdjLeftHomCodObj.
          (ΦAdjNTNTMapΦAdjRightObjMapx, x)¯SetArrVal
            ΦAdjLeftHomDomCIdΦAdjRightObjMapx
            
      ), 
      (ΦAdjLeft) CF (ΦAdjRight),
      cf_id (ΦAdjLeftHomCod),
      ΦAdjLeftHomCod,
      ΦAdjLeftHomCod
    ]"


text‹Components.›

lemma cf_adjunction_counit_components:
  shows "εC ΦNTMap =
    (
      λxΦAdjLeftHomCodObj.
        (ΦAdjNTNTMapΦAdjRightObjMapx, x)¯SetArrVal
          ΦAdjLeftHomDomCIdΦAdjRightObjMapx
          
    )"
    and "εC ΦNTDom = (ΦAdjLeft) CF (ΦAdjRight)"
    and "εC ΦNTCod = cf_id (ΦAdjLeftHomCod)"
    and "εC ΦNTDGDom = ΦAdjLeftHomCod"
    and "εC ΦNTDGCod = ΦAdjLeftHomCod"
  unfolding cf_adjunction_counit_def nt_field_simps 
  by (simp_all add: nat_omega_simps)

context is_cf_adjunction
begin

lemma cf_adjunction_counit_components':
  shows "εC ΦNTMap =
    (
      λx𝔇Obj.
        (ΦAdjNTNTMap𝔊ObjMapx, x)¯SetArrValCId𝔊ObjMapx
    )"
    and "εC ΦNTDom = 𝔉 CF 𝔊"
    and "εC ΦNTCod = cf_id 𝔇"
    and "εC ΦNTDGDom = 𝔇"
    and "εC ΦNTDGCod = 𝔇"
  unfolding cf_adjunction_counit_components
  by (cs_concl cs_simp: cat_cs_simps adj_cs_simps)+

mk_VLambda cf_adjunction_counit_components'(1)
  |vdomain cf_adjunction_counit_NTMap_vdomain[adj_cs_simps]|
  |app cf_adjunction_counit_NTMap_app[adj_cs_simps]|

end

mk_VLambda cf_adjunction_counit_components(1)
  |vsv cf_adjunction_counit_NTMap_vsv[adj_cs_intros]|

lemmas [adj_cs_simps] = 
  is_cf_adjunction.cf_adjunction_counit_NTMap_vdomain
  is_cf_adjunction.cf_adjunction_counit_NTMap_app


subsubsection‹Duality for the unit and counit›

lemma (in is_cf_adjunction) cf_adjunction_unit_NTMap_op:
  "ηC (op_cf_adj Φ)NTMap = εC ΦNTMap"
proof-
  interpret op_Φ: 
    is_cf_adjunction α ‹op_cat 𝔇 ‹op_cat  ‹op_cf 𝔊 ‹op_cf 𝔉 ‹op_cf_adj Φ
    by (rule is_cf_adjunction_op)
  show ?thesis
  proof
    (
      rule vsv_eqI, 
      unfold 
        cf_adjunction_counit_NTMap_vdomain 
        op_Φ.cf_adjunction_unit_NTMap_vdomain
    )
    fix a assume prems: "a  op_cat 𝔇Obj"
    then have a: "a  𝔇Obj" unfolding cat_op_simps by simp
    from is_cf_adjunction_axioms a show 
      "ηC (op_cf_adj Φ)NTMapa = εC ΦNTMapa"
      by 
        (
          cs_concl
            cs_simp: cat_Set_cs_simps cat_cs_simps cat_op_simps adj_cs_simps 
            cs_intro: 
              cat_arrow_cs_intros cat_cs_intros cat_op_intros cat_prod_cs_intros
        )
  qed 
    (
      simp_all add: 
        cat_op_simps cf_adjunction_counit_NTMap_vsv cf_adjunction_unit_NTMap_vsv
    )
qed


lemmas [cat_op_simps] = is_cf_adjunction.cf_adjunction_unit_NTMap_op

lemma (in is_cf_adjunction) cf_adjunction_counit_NTMap_op:
  "εC (op_cf_adj Φ)NTMap = ηC ΦNTMap"
  by 
    (
      rule is_cf_adjunction.cf_adjunction_unit_NTMap_op[
        OF is_cf_adjunction_op,
        unfolded is_cf_adjunction.cf_adjunction_op_cf_adj_op_cf_adj[
          OF is_cf_adjunction_axioms
          ],
        unfolded cat_op_simps,
        symmetric
      ]
   )

lemmas [cat_op_simps] = is_cf_adjunction.cf_adjunction_counit_NTMap_op

lemma (in is_cf_adjunction) op_ntcf_cf_adjunction_counit:
  "op_ntcf (εC Φ) = ηC (op_cf_adj Φ)"
  (is  = )
proof(rule vsv_eqI)
  interpret op_Φ: 
    is_cf_adjunction α ‹op_cat 𝔇 ‹op_cat  ‹op_cf 𝔊 ‹op_cf 𝔉 ‹op_cf_adj Φ
    by (rule is_cf_adjunction_op)
  have dom_lhs: "𝒟  = 5" unfolding op_ntcf_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟  = 5" 
    unfolding cf_adjunction_unit_def by (simp add: nat_omega_simps)
  show "𝒟  = 𝒟 " unfolding dom_lhs dom_rhs by simp
  show "a  𝒟   a = a" for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral, 
        fold nt_field_simps, 
        unfold cf_adjunction_unit_NTMap_op,
        unfold 
          cf_adjunction_counit_components' 
          cf_adjunction_unit_components'
          op_Φ.cf_adjunction_counit_components' 
          op_Φ.cf_adjunction_unit_components'
          cat_op_simps
      )
      simp_all
qed (auto simp: op_ntcf_def cf_adjunction_unit_def)

lemmas [cat_op_simps] = is_cf_adjunction.op_ntcf_cf_adjunction_counit

lemma (in is_cf_adjunction) op_ntcf_cf_adjunction_unit:
  "op_ntcf (ηC Φ) = εC (op_cf_adj Φ)"
  (is  = )
proof(rule vsv_eqI)
  interpret op_Φ: 
    is_cf_adjunction α ‹op_cat 𝔇 ‹op_cat  ‹op_cf 𝔊 ‹op_cf 𝔉 ‹op_cf_adj Φ
    by (rule is_cf_adjunction_op)
  have dom_lhs: "𝒟  = 5" 
    unfolding op_ntcf_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟  = 5" 
    unfolding cf_adjunction_counit_def by (simp add: nat_omega_simps)
  show "𝒟  = 𝒟 " unfolding dom_lhs dom_rhs by simp
  show "a  𝒟   a = a" for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral, 
        fold nt_field_simps, 
        unfold cf_adjunction_counit_NTMap_op,
        unfold 
          cf_adjunction_counit_components' 
          cf_adjunction_unit_components'
          op_Φ.cf_adjunction_counit_components' 
          op_Φ.cf_adjunction_unit_components'
          cat_op_simps
      )
      simp_all
qed (auto simp: op_ntcf_def cf_adjunction_counit_def)

lemmas [cat_op_simps] = is_cf_adjunction.op_ntcf_cf_adjunction_unit


subsubsection‹Natural transformation map›

lemma (in is_cf_adjunction) cf_adjunction_counit_NTMap_is_arr: 
  assumes "x  𝔇Obj"
  shows "εC ΦNTMapx : 𝔉ObjMap𝔊ObjMapx 𝔇 x"
proof-
  from assms have x: "x  op_cat 𝔇Obj" unfolding cat_op_simps by simp
  show ?thesis
    by 
      (
        rule is_cf_adjunction.cf_adjunction_unit_NTMap_is_arr[
          OF is_cf_adjunction_op x, 
          unfolded cf_adjunction_unit_NTMap_op cat_op_simps
          ]
      )
qed

lemma (in is_cf_adjunction) cf_adjunction_counit_NTMap_is_arr': 
  assumes "x  𝔇Obj"
    and "a = 𝔉ObjMap𝔊ObjMapx"
    and "b = x"
    and "𝔇' = 𝔇"
  shows "εC ΦNTMapx : a 𝔇' b"
  using assms(1) unfolding assms(2-4) by (rule cf_adjunction_counit_NTMap_is_arr)

lemmas [adj_cs_intros] = is_cf_adjunction.cf_adjunction_counit_NTMap_is_arr'

lemma (in is_cf_adjunction) cf_adjunction_counit_NTMap_vrange: 
  " (εC ΦNTMap)  𝔇Arr"
  by 
    (
      rule is_cf_adjunction.cf_adjunction_unit_NTMap_vrange[
        OF is_cf_adjunction_op,
        unfolded cf_adjunction_unit_NTMap_op cat_op_simps
        ]
    )


subsubsection‹Counit is a natural transformation›

lemma (in is_cf_adjunction) cf_adjunction_counit_is_ntcf:
  "εC Φ : 𝔉 CF 𝔊 CF cf_id 𝔇 : 𝔇 ↦↦Cα 𝔇"
proof-
  from is_cf_adjunction.cf_adjunction_unit_is_ntcf[OF is_cf_adjunction_op] have 
    "εC Φ :
      op_cf (op_cf 𝔉 CF op_cf 𝔊) CF op_cf (cf_id (op_cat 𝔇)) :
      op_cat (op_cat 𝔇) ↦↦Cα op_cat (op_cat 𝔇)"
    unfolding
      is_cf_adjunction.op_ntcf_cf_adjunction_unit[
        OF is_cf_adjunction_op, unfolded cat_op_simps, symmetric
        ]
    by (rule is_ntcf.is_ntcf_op)
  then show ?thesis unfolding cat_op_simps .
qed

lemma (in is_cf_adjunction) cf_adjunction_counit_is_ntcf':
  assumes "𝔖 = 𝔉 CF 𝔊"
    and "𝔖' = cf_id 𝔇"
    and "𝔄 = 𝔇"
    and "𝔅 = 𝔇"
  shows "εC Φ : 𝔖 CF 𝔖' : 𝔄 ↦↦Cα 𝔅"
  unfolding assms by (rule cf_adjunction_counit_is_ntcf)

lemmas [adj_cs_intros] = is_cf_adjunction.cf_adjunction_counit_is_ntcf'


subsubsection‹Every component of a counit is a universal arrow›

text‹
The lemmas in this subsection are based on elements of the statement of 
Theorem 1 in Chapter IV-1 in \cite{mac_lane_categories_2010}.
›

lemma (in is_cf_adjunction) cf_adj_umap_fo_counit:
  assumes "x  𝔇Obj" and "a  Obj"
  shows "op_cf_adj ΦAdjNTNTMapx, a =
    umap_fo 𝔉 x (𝔊ObjMapx) (εC ΦNTMapx) a"
  by
    (
      rule is_cf_adjunction.cf_adj_umap_of_unit[
        OF is_cf_adjunction_op,
        unfolded cat_op_simps,
        OF assms,
        unfolded cf_adjunction_unit_NTMap_op
        ]
    )

lemma (in is_cf_adjunction) cf_adjunction_counit_component_is_ua_fo:
  assumes "x  𝔇Obj"
  shows "universal_arrow_fo 𝔉 x (𝔊ObjMapx) (εC ΦNTMapx)"
  by 
    (
      rule is_cf_adjunction.cf_adjunction_unit_component_is_ua_of[
        OF is_cf_adjunction_op, 
        unfolded cat_op_simps, 
        OF assms,
        unfolded cf_adjunction_unit_NTMap_op
        ]
    )



subsection‹Counit-unit equations›


text‹
The following equations appear as part of the statement of 
Theorem 1 in Chapter IV-1 in \cite{mac_lane_categories_2010}.
These equations also appear in \cite{noauthor_wikipedia_2001},
where they are named counit-unit equations›.
›

lemma (in is_cf_adjunction) cf_adjunction_counit_unit:
  "(𝔊 CF-NTCF εC Φ) NTCF (ηC Φ NTCF-CF 𝔊) = ntcf_id 𝔊"
  (is (𝔊 CF-NTCF ) NTCF ( NTCF-CF 𝔊) = ntcf_id 𝔊)
proof(rule ntcf_eqI)
  from is_cf_adjunction_axioms show 
    "(𝔊 CF-NTCF ) NTCF ( NTCF-CF 𝔊) : 𝔊 CF 𝔊 : 𝔇 ↦↦Cα "
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros adj_cs_intros)
  show "ntcf_id 𝔊 : 𝔊 CF 𝔊 : 𝔇 ↦↦Cα "
    by (rule is_functor.cf_ntcf_id_is_ntcf[OF RL.is_functor_axioms])
  from is_cf_adjunction_axioms have dom_lhs:
    "𝒟 (((𝔊 CF-NTCF ) NTCF ( NTCF-CF 𝔊))NTMap) = 𝔇Obj"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros adj_cs_intros)
  from is_cf_adjunction_axioms have dom_rhs: "𝒟 (ntcf_id 𝔊NTMap) = 𝔇Obj"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: adj_cs_intros)
  show "((𝔊 CF-NTCF ) NTCF ( NTCF-CF 𝔊))NTMap = ntcf_id 𝔊NTMap"
  proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
    fix a assume prems: "a  𝔇Obj"
    let ?φ_aa = ΦAdjNTNTMap𝔊ObjMapa, a
    have "category α (cat_Set α)"
      by (rule category_cat_Set)
    from is_cf_adjunction_axioms prems
      L.category_axioms R.category_axioms (*speedup*)
      L.category_op R.category_op (*speedup*)
      LR.is_functor_axioms RL.is_functor_axioms (*speedup*)
      category_cat_Set (*speedup*)
    have
      "?φ_aaArrValNTMapa =
        (?φ_aa Acat_Set α ?φ_aa¯Ccat_Set α)ArrValCId𝔊ObjMapa"
      by 
        (
          cs_concl 
            cs_simp: 
              𝒵.cat_Set_Comp_ArrVal 
              cat_Set_the_inverse[symmetric] 
              cat_cs_simps adj_cs_simps cat_prod_cs_simps 
            cs_intro:
              cat_arrow_cs_intros 
              cat_cs_intros 
              cat_op_intros 
              adj_cs_intros 
              cat_prod_cs_intros
        )
    also from is_cf_adjunction_axioms prems 
      L.category_axioms R.category_axioms (*speedup*)
      L.category_op R.category_op (*speedup*)
      LR.is_functor_axioms RL.is_functor_axioms (*speedup*)
      category_cat_Set (*speedup*)   
    have " = CId𝔊ObjMapa"
      by (
          cs_concl 
            cs_simp: cat_cs_simps category.cat_the_inverse_Comp_CId
            cs_intro: 
              cat_arrow_cs_intros cat_cs_intros cat_op_intros cat_prod_cs_intros
        )
    finally have [cat_cs_simps]: 
      "(ΦAdjNTNTMap𝔊ObjMapa, a)ArrValNTMapa = 
        CId𝔊ObjMapa"
      by simp
    from 
      prems is_cf_adjunction_axioms 
      L.category_axioms R.category_axioms (*speedup*)
    show "((𝔊 CF-NTCF ) NTCF ( NTCF-CF 𝔊))NTMapa = ntcf_id 𝔊NTMapa"
      by
        (
          cs_concl
            cs_simp:
              cat_Set_the_inverse[symmetric]
              cf_adj_Comp_commute_RL
              cat_cs_simps
              adj_cs_simps
              cat_prod_cs_simps
              cat_op_simps
            cs_intro:
              cat_arrow_cs_intros
              cat_cs_intros
              adj_cs_intros
              cat_prod_cs_intros
              cat_op_intros
        )

  qed (auto intro: cat_cs_intros)

qed simp_all

lemmas [adj_cs_simps] = is_cf_adjunction.cf_adjunction_counit_unit

lemma (in is_cf_adjunction) cf_adjunction_unit_counit:
  "(εC Φ NTCF-CF 𝔉) NTCF (𝔉 CF-NTCF ηC Φ) = ntcf_id 𝔉"
  (is ( NTCF-CF 𝔉) NTCF (𝔉 CF-NTCF ) = ntcf_id 𝔉)
proof-
  from is_cf_adjunction_axioms have 𝔉η:
    "𝔉 CF-NTCF  : 𝔉 CF 𝔉 CF 𝔊 CF 𝔉 :  ↦↦Cα 𝔇"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros adj_cs_intros)
  from is_cf_adjunction_axioms have ε𝔉:
    " NTCF-CF 𝔉 : 𝔉 CF 𝔊 CF 𝔉 CF 𝔉 :  ↦↦Cα 𝔇"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros adj_cs_intros)
  from 𝔉η ε𝔉 have ε𝔉_𝔉η: 
    "( NTCF-CF 𝔉) NTCF (𝔉 CF-NTCF ) : 𝔉 CF 𝔉 :  ↦↦Cα 𝔇"
    by (cs_concl cs_intro: cat_cs_intros)
  from 
    is_cf_adjunction.cf_adjunction_counit_unit[
      OF is_cf_adjunction_op, 
      unfolded 
        op_ntcf_cf_adjunction_unit[symmetric]
        op_ntcf_cf_adjunction_counit[symmetric]
        op_ntcf_cf_ntcf_comp[symmetric]
        op_ntcf_ntcf_cf_comp[symmetric]
        op_ntcf_ntcf_vcomp[symmetric]
        op_ntcf_ntcf_vcomp[symmetric, OF ε𝔉 𝔉η]
        LR.cf_ntcf_id_op_cf
      ]
  have 
    "op_ntcf (op_ntcf (( NTCF-CF 𝔉) NTCF (𝔉 CF-NTCF ))) =
      op_ntcf (op_ntcf (ntcf_id 𝔉))"
    by simp
  from this is_cf_adjunction_axioms ε𝔉_𝔉η show ?thesis
    by (cs_prems cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_prod_cs_intros)
qed

lemmas [adj_cs_simps] = is_cf_adjunction.cf_adjunction_unit_counit



subsection‹
Construction of an adjunction from universal morphisms 
from objects to functors
›


text‹
The subsection presents the construction of an adjunction given 
a structured collection of universal morphisms from objects to functors.
The content of this subsection follows the statement and the proof
of Theorem 2-i in Chapter IV-1 in \cite{mac_lane_categories_2010}.
›


subsubsection‹
The natural transformation associated with the adjunction
constructed from universal morphisms from objects to functors
›

definition cf_adjunction_AdjNT_of_unit :: "V  V  V  V  V"
  where "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η =
    [
      (λcd(op_cat (𝔉HomDom) ×C 𝔉HomCod)Obj.
        umap_of 𝔊 (cd0) (𝔉ObjMapcd0) (ηNTMapcd0) (cd1)),
      HomO.Cα𝔉HomCod(𝔉-,-),
      HomO.Cα𝔉HomDom(-,𝔊-),
      op_cat (𝔉HomDom) ×C (𝔉HomCod),
      cat_Set α
    ]"


text‹Components.›

lemma cf_adjunction_AdjNT_of_unit_components:
  shows "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap =
    (
      λcd(op_cat (𝔉HomDom) ×C 𝔉HomCod)Obj.
        umap_of 𝔊 (cd0) (𝔉ObjMapcd0) (ηNTMapcd0)  (cd1)
    )"
    and "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTDom = HomO.Cα𝔉HomCod(𝔉-,-)"
    and "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTCod = HomO.Cα𝔉HomDom(-,𝔊-)"
    and "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTDGDom =
      op_cat (𝔉HomDom) ×C (𝔉HomCod)"
    and "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTDGCod = cat_Set α"
  unfolding cf_adjunction_AdjNT_of_unit_def nt_field_simps
  by (simp_all add: nat_omega_simps)


subsubsection‹Natural transformation map›

lemma cf_adjunction_AdjNT_of_unit_NTMap_vsv[adj_cs_intros]:
  "vsv (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap)"
  unfolding cf_adjunction_AdjNT_of_unit_components by simp

lemma cf_adjunction_AdjNT_of_unit_NTMap_vdomain[adj_cs_simps]:
  assumes "𝔉 :  ↦↦Cα 𝔇"
  shows "𝒟 (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap) = (op_cat  ×C 𝔇)Obj"
proof-
  interpret is_functor α  𝔇 𝔉 by (rule assms(1))
  show ?thesis 
    unfolding cf_adjunction_AdjNT_of_unit_components 
    by (simp add: cat_cs_simps)
qed

lemma cf_adjunction_AdjNT_of_unit_NTMap_app[adj_cs_simps]:
  assumes "𝔉 :  ↦↦Cα 𝔇" and "c  Obj" and "d  𝔇Obj"
  shows 
    "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMapc, d =
      umap_of 𝔊 c (𝔉ObjMapc) (ηNTMapc) d"
proof-
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(1))
  from assms have "[c, d]  (op_cat  ×C 𝔇)Obj"
    by (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_prod_cs_intros)
  then show "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap c, d = 
    umap_of 𝔊 c (𝔉ObjMapc) (ηNTMapc) d"
    unfolding cf_adjunction_AdjNT_of_unit_components 
    by (simp add: nat_omega_simps cat_cs_simps)
qed

lemma cf_adjunction_AdjNT_of_unit_NTMap_vrange:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
  shows " (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap)  cat_Set αArr"
proof-
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(3))
  show ?thesis
  proof
    (
      rule vsv.vsv_vrange_vsubset, 
      unfold cf_adjunction_AdjNT_of_unit_NTMap_vdomain[OF assms(3)]
    )
    show "vsv (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap)" 
      by (intro adj_cs_intros)
    fix cd assume prems: "cd  (op_cat  ×C 𝔇)Obj"
    then obtain c d where cd_def: "cd = [c, d]"
      and c: "c  Obj"
      and d: "d  𝔇Obj"
      by 
        (
          auto 
            simp: cat_op_simps 
            elim: 
              cat_prod_2_ObjE[OF 𝔉.HomDom.category_op 𝔉.HomCod.category_axioms]
        )
    from assms c d show 
      "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMapcd  cat_Set αArr"
      unfolding cd_def
      by (cs_concl cs_simp: cat_cs_simps adj_cs_simps cs_intro: cat_cs_intros)
  qed
qed


subsubsection‹
Adjunction constructed from universal morphisms 
from objects to functors is an adjunction
›

lemma cf_adjunction_AdjNT_of_unit_is_ntcf:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
  shows "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η :
    HomO.Cα𝔇(𝔉-,-) CF HomO.Cα(-,𝔊-) :
    op_cat  ×C 𝔇 ↦↦Cα cat_Set α"
proof-

  interpret: category α  by (rule assms(1))
  interpret 𝔇: category α 𝔇 by (rule assms(2))
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(3))
  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(4))
  interpret η: is_ntcf α   ‹cf_id  𝔊 CF 𝔉 η by (rule assms(5))

  show ?thesis
  proof(intro is_ntcfI')

    show "vfsequence (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η)"
      unfolding cf_adjunction_AdjNT_of_unit_def by simp
    show "vcard (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η) = 5"
      unfolding cf_adjunction_AdjNT_of_unit_def by (simp add: nat_omega_simps)
    from assms(2,3) show 
      "HomO.Cα𝔇(𝔉-,-) : op_cat  ×C 𝔇 ↦↦Cα cat_Set α"
      by (cs_concl cs_intro: cat_cs_intros)
    from assms show "HomO.Cα(-,𝔊-) : op_cat  ×C 𝔇 ↦↦Cα cat_Set α"
      by (cs_concl cs_intro: cat_cs_intros)
    show "vsv (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap)" 
      by (intro adj_cs_intros)
    from assms show 
      "𝒟 (cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMap) = (op_cat  ×C 𝔇)Obj"
      by (cs_concl cs_simp: cat_cs_simps adj_cs_simps)

    show "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMapcd :
      HomO.Cα𝔇(𝔉-,-)ObjMapcd cat_Set α
      HomO.Cα(-,𝔊-)ObjMapcd"
      if "cd  (op_cat  ×C 𝔇)Obj" for cd
    proof-
      from that obtain c d 
        where cd_def: "cd = [c, d]" and c: "c  Obj" and d: "d  𝔇Obj"
        by 
          (
            auto 
              simp: cat_op_simps 
              elim: cat_prod_2_ObjE[OF ℭ.category_op 𝔇.category_axioms]
          )
      from assms c d show ?thesis
        unfolding cd_def
        by 
          (
            cs_concl 
              cs_simp: adj_cs_simps cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
    qed

    show 
      "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMapc'd' Acat_Set α
        HomO.Cα𝔇(𝔉-,-)ArrMapgf =
          HomO.Cα(-,𝔊-)ArrMapgf Acat_Set α
            cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηNTMapcd"
      if "gf : cd op_cat  ×C 𝔇 c'd'" for cd c'd' gf 
    proof-
      from that obtain g f c c' d d'
        where gf_def: "gf = [g, f]"
          and cd_def: "cd = [c, d]"
          and c'd'_def: "c'd' = [c', d']"
          and g: "g : c'  c" 
          and f: "f : d 𝔇 d'"
        by 
          (
            auto 
              simp: cat_op_simps 
              elim: cat_prod_2_is_arrE[OF ℭ.category_op 𝔇.category_axioms]
          ) 
      from assms g f that show ?thesis
        unfolding gf_def cd_def c'd'_def
        by 
          (
            cs_concl 
              cs_simp: cf_umap_of_cf_hom_unit_commute adj_cs_simps cat_cs_simps
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
    qed

  qed (auto simp: cf_adjunction_AdjNT_of_unit_components cat_cs_simps)

qed

lemma cf_adjunction_AdjNT_of_unit_is_ntcf'[adj_cs_intros]:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
    and "𝔖 = HomO.Cα𝔇(𝔉-,-)"
    and "𝔖' = HomO.Cα(-,𝔊-)"
    and "𝔄 = op_cat  ×C 𝔇"
    and "𝔅 = cat_Set α"
  shows "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η : 𝔖 CF 𝔖' : 𝔄 ↦↦Cα 𝔅"
  using assms(1-5) unfolding assms(6-9) 
  by (rule cf_adjunction_AdjNT_of_unit_is_ntcf)


subsubsection‹
Adjunction constructed from universal morphisms from objects to functors
›

definition cf_adjunction_of_unit :: "V  V  V  V  V"
  where "cf_adjunction_of_unit α 𝔉 𝔊 η =
    [𝔉, 𝔊, cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η]"


text‹Components.›

lemma cf_adjunction_of_unit_components:
  shows [adj_cs_simps]: "cf_adjunction_of_unit α 𝔉 𝔊 ηAdjLeft = 𝔉"
    and [adj_cs_simps]: "cf_adjunction_of_unit α 𝔉 𝔊 ηAdjRight = 𝔊"
    and "cf_adjunction_of_unit α 𝔉 𝔊 ηAdjNT =
      cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η"
  unfolding cf_adjunction_of_unit_def adj_field_simps
  by (simp_all add: nat_omega_simps)


text‹Natural transformation map.›

lemma cf_adjunction_of_unit_AdjNT_NTMap_vdomain[adj_cs_simps]:
  assumes "𝔉 :  ↦↦Cα 𝔇"
  shows "𝒟 (cf_adjunction_of_unit α 𝔉 𝔊 ηAdjNTNTMap) = 
    (op_cat  ×C 𝔇)Obj"
  using assms 
  unfolding cf_adjunction_of_unit_components(3)
  by (rule cf_adjunction_AdjNT_of_unit_NTMap_vdomain)

lemma cf_adjunction_of_unit_AdjNT_NTMap_app[adj_cs_simps]:
  assumes "𝔉 :  ↦↦Cα 𝔇" and "c  Obj" and "d  𝔇Obj"
  shows 
    "cf_adjunction_of_unit α 𝔉 𝔊 ηAdjNTNTMapc, d =
      umap_of 𝔊 c (𝔉ObjMapc) (ηNTMapc) d"
  using assms 
  unfolding cf_adjunction_of_unit_components(3)
  by (rule cf_adjunction_AdjNT_of_unit_NTMap_app)


text‹
The adjunction constructed from universal morphisms from objects to 
functors is an adjunction.
›

lemma cf_adjunction_of_unit_is_cf_adjunction:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
    and "x. x  Obj  universal_arrow_of 𝔊 x (𝔉ObjMapx) (ηNTMapx)"
  shows "cf_adjunction_of_unit α 𝔉 𝔊 η : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η) = η"
proof-

  interpret: category α  by (rule assms(1))
  interpret 𝔇: category α 𝔇 by (rule assms(2))
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(3))
  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(4))
  interpret η: is_ntcf α   ‹cf_id  𝔊 CF 𝔉 η by (rule assms(5))

  show caou_η: "cf_adjunction_of_unit α 𝔉 𝔊 η : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
  proof
    (
      intro 
        is_cf_adjunctionI[OF _ _ assms(1-4)] 
        is_iso_ntcf_if_bnt_proj_snd_is_iso_ntcf[
          OF ℭ.category_op 𝔇.category_axioms
          ],
      unfold cat_op_simps cf_adjunction_of_unit_components
    )
    show caou_η: "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 η :
      HomO.Cα𝔇(𝔉-,-) CF HomO.Cα(-,𝔊-) :
      op_cat  ×C 𝔇 ↦↦Cα cat_Set α"
      unfolding cf_adjunction_of_unit_components
      by (rule cf_adjunction_AdjNT_of_unit_is_ntcf[OF assms(1-5)])
    fix a assume prems: "a  Obj"
    have ua_of_ηa:
      "ntcf_ua_of α 𝔊 a (𝔉ObjMapa) (ηNTMapa) :
        HomO.Cα𝔇(𝔉ObjMapa,-) CF.iso HomO.Cα(a,-) CF 𝔊 :
        𝔇 ↦↦Cα cat_Set α"
      by 
        (
          rule is_functor.cf_ntcf_ua_of_is_iso_ntcf[
            OF assms(4) assms(6)[OF prems]
            ]
        )
    have [adj_cs_simps]:
      "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηop_cat ,𝔇(a,-)NTCF =
        ntcf_ua_of α 𝔊 a (𝔉ObjMapa) (ηNTMapa)"
    proof(rule ntcf_eqI)
      from assms(1-5) caou_η prems show lhs: 
        "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηop_cat ,𝔇(a,-)NTCF :
          HomO.Cα𝔇(𝔉ObjMapa,-) CF HomO.Cα(a,-) CF 𝔊 :
          𝔇 ↦↦Cα cat_Set α"
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros
          )
      from ua_of_ηa show rhs:
        "ntcf_ua_of α 𝔊 a (𝔉ObjMapa) (ηNTMapa) :
          HomO.Cα𝔇(𝔉ObjMapa,-) CF HomO.Cα(a,-) CF 𝔊 :
          𝔇 ↦↦Cα cat_Set α"
        by (cs_concl cs_intro: ntcf_cs_intros)
      from lhs have dom_lhs:
        "𝒟 ((cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηop_cat ,𝔇(a,-)NTCF)NTMap) =
          𝔇Obj"
        by (cs_concl cs_simp: cat_cs_simps)
      from lhs assms(4) have dom_rhs:
        "𝒟 (ntcf_ua_of α 𝔊 a (𝔉ObjMapa) (ηNTMapa)NTMap) = 𝔇Obj"
        by (cs_concl cs_simp: cat_cs_simps)
      show 
        "(cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηop_cat ,𝔇(a,-)NTCF)NTMap =
          ntcf_ua_of α 𝔊 a (𝔉ObjMapa) (ηNTMapa)NTMap"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
        fix d assume prems': "d  𝔇Obj"
        from assms(3,4) prems prems' show 
          "(cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηop_cat ,𝔇(a,-)NTCF)NTMapd =
            ntcf_ua_of α 𝔊 a (𝔉ObjMapa) (ηNTMapa)NTMapd"
          by (cs_concl cs_simp: adj_cs_simps cat_cs_simps)
      qed (simp_all add: bnt_proj_snd_NTMap_vsv 𝔊.ntcf_ua_of_NTMap_vsv)
    qed simp_all
    from assms(1-5) assms(6)[OF prems] prems show 
      "cf_adjunction_AdjNT_of_unit α 𝔉 𝔊 ηop_cat ,𝔇(a,-)NTCF :
        HomO.Cα𝔇(𝔉-,-)op_cat ,𝔇(a,-)CF CF.iso
        HomO.Cα(-,𝔊-)op_cat ,𝔇(a,-)CF :
        𝔇 ↦↦Cα cat_Set α"
      by (cs_concl cs_simp: adj_cs_simps cat_cs_simps cs_intro: cat_cs_intros)
  qed (auto simp: cf_adjunction_of_unit_def nat_omega_simps)

  show "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η) = η"
  proof(rule ntcf_eqI)
    from caou_η show lhs:
      "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η) :
        cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
      by (cs_concl cs_intro: adj_cs_intros)
    show rhs: "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
      by (auto intro: cat_cs_intros)
    from lhs have dom_lhs:
      "𝒟 (ηC (cf_adjunction_of_unit α 𝔉 𝔊 η)NTMap) = Obj"
      by (cs_concl cs_simp: cat_cs_simps)
    have dom_rhs: "𝒟 (ηNTMap) = Obj" by (auto simp: cat_cs_simps)
    show "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η)NTMap = ηNTMap"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume prems: "a  Obj"
      from assms(1-5) prems caou_η show 
        "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η)NTMapa = ηNTMapa"
        by 
          (
            cs_concl 
              cs_simp: 
                adj_cs_simps cat_cs_simps cf_adjunction_of_unit_components(3) 
              cs_intro: cat_cs_intros
          )
    qed (auto intro: adj_cs_intros)
  qed simp_all

qed



subsection‹
Construction of an adjunction from a functor and universal morphisms 
from objects to functors
›


text‹
The subsection presents the construction of an adjunction given 
a functor and a structured collection of universal morphisms 
from objects to functors.
The content of this subsection follows the statement and the proof
of Theorem 2-ii in Chapter IV-1 in \cite{mac_lane_categories_2010}.
›


subsubsection‹Left adjoint›

definition cf_la_of_ra :: "(V  V)  V  V  V"
  where "cf_la_of_ra F 𝔊 η =
    [
      (λx𝔊HomCodObj. F x),
      (
        λh𝔊HomCodArr. THE f'.
          f' : F (𝔊HomCodDomh) 𝔊HomDom F (𝔊HomCodCodh) 
            ηNTMap𝔊HomCodCodh A𝔊HomCod h =
              (
                umap_of
                  𝔊
                  (𝔊HomCodDomh)
                  (F (𝔊HomCodDomh))
                  (ηNTMap𝔊HomCodDomh)
                  (F (𝔊HomCodCodh))
              )ArrValf'
      ),
      𝔊HomCod,
      𝔊HomDom
    ]"


text‹Components.›

lemma cf_la_of_ra_components:
  shows "cf_la_of_ra F 𝔊 ηObjMap = (λx𝔊HomCodObj. F x)"
    and "cf_la_of_ra F 𝔊 ηArrMap =
      (
        λh𝔊HomCodArr. THE f'.
          f' : F (𝔊HomCodDomh) 𝔊HomDom F (𝔊HomCodCodh) 
          ηNTMap𝔊HomCodCodh A𝔊HomCod h =
            (
              umap_of
                𝔊 
                (𝔊HomCodDomh)
                (F (𝔊HomCodDomh))
                (ηNTMap𝔊HomCodDomh)
                (F (𝔊HomCodCodh))
            )ArrValf'
      )"
    and "cf_la_of_ra F 𝔊 ηHomDom = 𝔊HomCod"
    and "cf_la_of_ra F 𝔊 ηHomCod = 𝔊HomDom"
  unfolding cf_la_of_ra_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda cf_la_of_ra_components(1)
  |vsv cf_la_of_ra_ObjMap_vsv[adj_cs_intros]|

mk_VLambda (in is_functor) 
  cf_la_of_ra_components(1)[where ?𝔊=𝔉, unfolded cf_HomCod]
  |vdomain cf_la_of_ra_ObjMap_vdomain[adj_cs_simps]|
  |app cf_la_of_ra_ObjMap_app[adj_cs_simps]|

lemmas [adj_cs_simps] =
  is_functor.cf_la_of_ra_ObjMap_vdomain
  is_functor.cf_la_of_ra_ObjMap_app
  

subsubsection‹Arrow map›

mk_VLambda cf_la_of_ra_components(2)
  |vsv cf_la_of_ra_ArrMap_vsv[adj_cs_intros]|

mk_VLambda (in is_functor) 
  cf_la_of_ra_components(2)[where ?𝔊=𝔉, unfolded cf_HomCod cf_HomDom]
  |vdomain cf_la_of_ra_ArrMap_vdomain[adj_cs_simps]|
  |app cf_la_of_ra_ArrMap_app| (*not for general use*)

lemmas [adj_cs_simps] = is_functor.cf_la_of_ra_ArrMap_vdomain

lemma (in is_functor) cf_la_of_ra_ArrMap_app':
  assumes "h : a 𝔅 b"
  shows 
    "cf_la_of_ra F 𝔉 ηArrMaph =
      (
        THE f'.
          f' : F a 𝔄 F b 
          ηNTMapb A𝔅 h = umap_of 𝔉 a (F a) (ηNTMapa) (F b)ArrValf'
      )"
proof-
  from assms have h: "h  𝔅Arr" by (simp add: cat_cs_intros)
  from assms have h_Dom: "𝔅Domh = a" and h_Cod: "𝔅Codh = b"
    by (simp_all add: cat_cs_simps)
  show ?thesis by (rule cf_la_of_ra_ArrMap_app[OF h, unfolded h_Dom h_Cod])
qed

lemma cf_la_of_ra_ArrMap_app_unique:
  assumes "𝔊 : 𝔇 ↦↦Cα "
    and "f : a  b"
    and "universal_arrow_of 𝔊 a (cf_la_of_ra F 𝔊 ηObjMapa) (ηNTMapa)"
    and "universal_arrow_of 𝔊 b (cf_la_of_ra F 𝔊 ηObjMapb) (ηNTMapb)"
  shows "cf_la_of_ra F 𝔊 ηArrMapf : F a 𝔇 F b"
    and "ηNTMapb A f = umap_of
      𝔊 a (F a) (ηNTMapa) (F b)ArrValcf_la_of_ra F 𝔊 ηArrMapf"
    and "f'.
      
        f' : F a 𝔇 F b;
        ηNTMapb A f = umap_of 𝔊 a (F a) (ηNTMapa) (F b)ArrValf'
        cf_la_of_ra F 𝔊 ηArrMapf = f'"
proof-

  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(1))

  from assms(2) have a: "a  Obj" and b: "b  Obj" 
    by (simp_all add: cat_cs_intros)
  note ua_η_a = 𝔊.universal_arrow_ofD[OF assms(3)]
  note ua_η_b = 𝔊.universal_arrow_ofD[OF assms(4)]
  from ua_η_b(2) have [cat_cs_intros]: 
    " c = b; c' = 𝔊ObjMapcf_la_of_ra F 𝔊 ηObjMapb  
      ηNTMapb : c  c'"
    for c c'
    by auto
  from assms(1,2) ua_η_a(2) have ηa_f:
    "ηNTMapb A f : a  𝔊ObjMapcf_la_of_ra F 𝔊 ηObjMapb"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  from assms(1,2) have lara_a: "cf_la_of_ra F 𝔊 ηObjMapa = F a"
    and lara_b: "cf_la_of_ra F 𝔊 ηObjMapb = F b"
    by (cs_concl cs_simp: adj_cs_simps cs_intro: cat_cs_intros)+

  from theD
    [
      OF 
        ua_η_a(3)[OF ua_η_b(1) ηa_f, unfolded lara_a lara_b] 
        𝔊.cf_la_of_ra_ArrMap_app'[OF assms(2), of F η]
    ]
  show "cf_la_of_ra F 𝔊 ηArrMapf : F a 𝔇 F b"
    and "ηNTMapb A f = umap_of
      𝔊 a (F a) (ηNTMapa) (F b)ArrValcf_la_of_ra F 𝔊 ηArrMapf"
    and "f'.
      
        f' : F a 𝔇 F b;
        ηNTMapb A f = umap_of 𝔊 a (F a) (ηNTMapa) (F b)ArrValf'
        cf_la_of_ra F 𝔊 ηArrMapf = f'"
    by blast+

qed

lemma cf_la_of_ra_ArrMap_app_is_arr[adj_cs_intros]:
  assumes "𝔊 : 𝔇 ↦↦Cα "
    and "f : a  b"
    and "universal_arrow_of 𝔊 a (cf_la_of_ra F 𝔊 ηObjMapa) (ηNTMapa)"
    and "universal_arrow_of 𝔊 b (cf_la_of_ra F 𝔊 ηObjMapb) (ηNTMapb)"
    and "Fa = F a"
    and "Fb = F b"
  shows "cf_la_of_ra F 𝔊 ηArrMapf : Fa 𝔇 Fb"
  using assms(1-4) unfolding assms(5,6) by (rule cf_la_of_ra_ArrMap_app_unique)


subsubsection‹
An adjunction constructed from a functor and universal morphisms 
from objects to functors is an adjunction
›

lemma cf_la_of_ra_is_functor:
  assumes "𝔊 : 𝔇 ↦↦Cα "
    and "c. c  Obj  F c  𝔇Obj"
    and "c. c  Obj 
      universal_arrow_of 𝔊 c (cf_la_of_ra F 𝔊 ηObjMapc) (ηNTMapc)"
    and "c c' h. h : c  c' 
      𝔊ArrMapcf_la_of_ra F 𝔊 ηArrMaph A (ηNTMapc) =
        (ηNTMapc') A h"
  shows "cf_la_of_ra F 𝔊 η :  ↦↦Cα 𝔇" (is ?𝔉 :  ↦↦Cα 𝔇)
proof-

  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(1))

  show "cf_la_of_ra F 𝔊 η :  ↦↦Cα 𝔇"
  proof(rule is_functorI')

    show "vfsequence ?𝔉" unfolding cf_la_of_ra_def by auto
    show "vcard ?𝔉 = 4" 
      unfolding cf_la_of_ra_def by (simp add: nat_omega_simps)
    show " (?𝔉ObjMap)  𝔇Obj"
    proof(rule vsv.vsv_vrange_vsubset, unfold 𝔊.cf_la_of_ra_ObjMap_vdomain)
      fix x assume "x  Obj"
      with assms(1) show "?𝔉ObjMapx  𝔇Obj"
        by (cs_concl cs_simp: adj_cs_simps cs_intro: assms(2))
    qed (auto intro: adj_cs_intros)

    show "?𝔉ArrMapf : ?𝔉ObjMapa 𝔇 ?𝔉ObjMapb"
      if "f : a  b" for a b f
    proof-
      from that have a: "a  Obj" and b: "b  Obj" 
        by (simp_all add: cat_cs_intros)
      have ua_η_a: "universal_arrow_of 𝔊 a (?𝔉ObjMapa) (ηNTMapa)"
        and ua_η_b: "universal_arrow_of 𝔊 b (?𝔉ObjMapb) (ηNTMapb)"
        by (intro assms(3)[OF a] assms(3)[OF b])+
      from a b cf_la_of_ra_ArrMap_app_unique(1)[OF assms(1) that ua_η_a ua_η_b] 
      show ?thesis 
        by (cs_concl cs_simp: adj_cs_simps)
    qed

    show "?𝔉ArrMapg A f = ?𝔉ArrMapg A𝔇 ?𝔉ArrMapf"
      if "g : b  c" and "f : a  b" for b c g a f
    proof-

      from that have a: "a  Obj" and b: "b  Obj" and c: "c  Obj" 
        by (simp_all add: cat_cs_intros)
      from assms(1) that have gf: "g A f : a  c"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

      note ua_η_a = assms(3)[OF a]
        and ua_η_b = assms(3)[OF b]
        and ua_η_c = assms(3)[OF c]

      note lara_f = 
        cf_la_of_ra_ArrMap_app_unique[OF assms(1) that(2) ua_η_a ua_η_b]
      note lara_g = 
        cf_la_of_ra_ArrMap_app_unique[OF assms(1) that(1) ua_η_b ua_η_c]
      note lara_gf = 
        cf_la_of_ra_ArrMap_app_unique[OF assms(1) gf ua_η_a ua_η_c]

      note ua_η_a = 𝔊.universal_arrow_ofD[OF ua_η_a]
        and ua_η_b = 𝔊.universal_arrow_ofD[OF ua_η_b]
        and ua_η_c = 𝔊.universal_arrow_ofD[OF ua_η_c]
      
      from ua_η_a(2) assms(1) that have ηa: 
        "ηNTMapa : a  𝔊ObjMapF a"
        by (cs_prems cs_simp: adj_cs_simps cs_intro: cat_cs_intros)
      from ua_η_b(2) assms(1) that have ηb: 
        "ηNTMapb : b  𝔊ObjMapF b"
        by (cs_prems cs_simp: adj_cs_simps cs_intro: cat_cs_intros)
      from ua_η_c(2) assms(1) that have ηc: 
        "ηNTMapc : c  𝔊ObjMapF c"
        by (cs_prems cs_simp: adj_cs_simps cs_intro: cat_cs_intros)

      from assms(1) that ηc have
        "ηNTMapc A (g A f) = (ηNTMapc A g) A f"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      also from assms(1) lara_g(1) that(2) ηb have " =
        𝔊ArrMap?𝔉ArrMapg A (ηNTMapb A f)"
        by 
          (
            cs_concl 
              cs_simp: lara_g(2) cat_cs_simps 
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
      also from assms(1) lara_f(1) ηa have " =
        𝔊ArrMap?𝔉ArrMapg A 
          (𝔊ArrMap?𝔉ArrMapf A ηNTMapa)"
        by (cs_concl cs_simp: lara_f(2) cat_cs_simps)
      finally have [symmetric, cat_cs_simps]: 
        "ηNTMapc A (g A f) = ".
      from assms(1) this ηa ηb ηc lara_g(1) lara_f(1) have 
        "ηNTMapc A (g A f) =
          umap_of 𝔊 a (F a) (ηNTMapa) (F c)ArrVal?𝔉ArrMapg A𝔇
          ?𝔉ArrMapf"
        by 
          ( 
            cs_concl 
              cs_simp: adj_cs_simps cat_cs_simps 
              cs_intro: adj_cs_intros cat_cs_intros
          )
      moreover from assms(1) lara_g(1) lara_f(1) have 
        "?𝔉ArrMapg A𝔇 ?𝔉ArrMapf : F a 𝔇 F c"
        by (cs_concl cs_intro: adj_cs_intros cat_cs_intros)
      ultimately show ?thesis by (intro lara_gf(3))

    qed

    show "?𝔉ArrMapCIdc = 𝔇CId?𝔉ObjMapc" if "c  Obj" for c 
    proof-
      note lara_c = cf_la_of_ra_ArrMap_app_unique[
          OF 
            assms(1) 
            𝔊.HomCod.cat_CId_is_arr[OF that] 
            assms(3)[OF that] 
            assms(3)[OF that]
          ]
      from assms(1) that have 𝔇c: "𝔇CIdF c : F c 𝔇 F c "
        by (cs_concl cs_simp: cat_cs_simps cs_intro: assms(2) cat_cs_intros)
      from 𝔊.universal_arrow_ofD(2)[OF assms(3)[OF that]] assms(1) that have ηc: 
        "ηNTMapc : c  𝔊ObjMapF c"
        by (cs_prems cs_simp: adj_cs_simps cs_intro: cat_cs_intros)
      from assms(1) that ηc have 
        "ηNTMapc A CIdc =
          umap_of 𝔊 c (F c) (ηNTMapc) (F c)ArrVal𝔇CIdF c"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: assms(2) cat_cs_intros)
      note [cat_cs_simps] = lara_c(3)[OF 𝔇c this]
      from assms(1) that 𝔇c show ?thesis
        by (cs_concl cs_simp: adj_cs_simps cat_cs_simps cs_intro: cat_cs_intros)
    qed
  qed (auto simp: cf_la_of_ra_components cat_cs_intros cat_cs_simps)

qed

lemma cf_la_of_ra_is_ntcf:  
  fixes F 𝔊 η
  defines "𝔉  cf_la_of_ra F 𝔊 η"
  assumes "𝔊 : 𝔇 ↦↦Cα "
    and "c. c  Obj  F c  𝔇Obj"
    and "c. c  Obj 
      universal_arrow_of 𝔊 c (𝔉ObjMapc) (ηNTMapc)"
    and "c c' h. h : c  c' 
      𝔊ArrMap𝔉ArrMaph A (ηNTMapc) = (ηNTMapc') A h"
    and "vfsequence η"
    and "vcard η = 5"
    and "ηNTDom = cf_id "
    and "ηNTCod = 𝔊 CF 𝔉"
    and "ηNTDGDom = "
    and "ηNTDGCod = "
    and "vsv (ηNTMap)"
    and "𝒟 (ηNTMap) = Obj"
  shows "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
proof-
  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(2))
  have 𝔉: "𝔉 :  ↦↦Cα 𝔇"
    unfolding 𝔉_def
    by (auto intro: cf_la_of_ra_is_functor[OF assms(2-5)[unfolded assms(1)]])
  show "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
  proof(rule is_ntcfI')
    from assms(2) show "cf_id  :  ↦↦Cα "
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from assms(2) 𝔉 show "𝔊 CF 𝔉 :  ↦↦Cα "
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show "ηNTMapa : cf_id ObjMapa  (𝔊 CF 𝔉)ObjMapa"
      if "a  Obj" for a
      using assms(2) 𝔉 that 𝔊.universal_arrow_ofD(2)[OF assms(4)[OF that]]
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show 
      "ηNTMapb A cf_id ArrMapf =
        (𝔊 CF 𝔉)ArrMapf A ηNTMapa"
      if "f : a  b" for a b f
      using assms(2) 𝔉 that 
      by (cs_concl cs_simp: assms(5) cat_cs_simps cs_intro: cat_cs_intros)
  qed (auto intro: assms(6-13))
qed

lemma cf_la_of_ra_is_unit:  
  fixes F 𝔊 η
  defines "𝔉  cf_la_of_ra F 𝔊 η"
  assumes "category α "
    and "category α 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "c. c  Obj  F c  𝔇Obj"
    and "c. c  Obj 
      universal_arrow_of 𝔊 c (𝔉ObjMapc) (ηNTMapc)"
    and "c c' h. h : c  c' 
      𝔊ArrMap𝔉ArrMaph A (ηNTMapc) = (ηNTMapc') A h"
    and "vfsequence η"
    and "vcard η = 5"
    and "ηNTDom = cf_id "
    and "ηNTCod = 𝔊 CF 𝔉"
    and "ηNTDGDom = "
    and "ηNTDGCod = "
    and "vsv (ηNTMap)"
    and "𝒟 (ηNTMap) = Obj"
  shows "cf_adjunction_of_unit α 𝔉 𝔊 η : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η) = η"
proof-
  note 𝔉 = cf_la_of_ra_is_functor[
    where F=F and η=η, OF assms(4-7)[unfolded 𝔉_def], simplified
    ]
  note η = cf_la_of_ra_is_ntcf[OF assms(4-15)[unfolded 𝔉_def], simplified]
  show "cf_adjunction_of_unit α 𝔉 𝔊 η : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η) = η"
    by 
      (
        intro 
          cf_adjunction_of_unit_is_cf_adjunction
            [
              OF assms(2,3) 𝔉 assms(4) η assms(6)[unfolded 𝔉_def], 
              simplified, 
              folded 𝔉_def
            ]
      )+
qed



subsection‹
Construction of an adjunction from universal morphisms 
from functors to objects
›


subsubsection‹Definition and elementary properties›


text‹
The subsection presents the construction of an adjunction given 
a structured collection of universal morphisms from functors to objects.
The content of this subsection follows the statement and the proof
of Theorem 2-iii in Chapter IV-1 in \cite{mac_lane_categories_2010}.
›

definition cf_adjunction_of_counit :: "V  V  V  V  V"
  where "cf_adjunction_of_counit α 𝔉 𝔊 ε =
    op_cf_adj (cf_adjunction_of_unit α (op_cf 𝔊) (op_cf 𝔉) (op_ntcf ε))"


text‹Components.›

lemma cf_adjunction_of_counit_components:
  shows "cf_adjunction_of_counit α 𝔉 𝔊 εAdjLeft = op_cf (op_cf 𝔉)"
    and "cf_adjunction_of_counit α 𝔉 𝔊 εAdjRight = op_cf (op_cf 𝔊)"
    and "cf_adjunction_of_counit α 𝔉 𝔊 εAdjNT = op_cf_adj_nt
      (op_cf 𝔊HomDom)
      (op_cf 𝔊HomCod)
      (cf_adjunction_AdjNT_of_unit α (op_cf 𝔊) (op_cf 𝔉) (op_ntcf ε))"
  unfolding 
    cf_adjunction_of_counit_def 
    op_cf_adj_components 
    cf_adjunction_of_unit_components
  by (simp_all add: cat_op_simps)


subsubsection‹Natural transformation map›

lemma cf_adjunction_of_counit_NTMap_vsv: 
  "vsv (cf_adjunction_of_counit α 𝔉 𝔊 εAdjNTNTMap)"
  unfolding cf_adjunction_of_counit_components by (rule inv_ntcf_NTMap_vsv)
  


subsubsection‹
An adjunction constructed from universal morphisms 
from functors to objects is an adjunction
›

lemma cf_adjunction_of_counit_is_cf_adjunction:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "ε : 𝔉 CF 𝔊 CF cf_id 𝔇 : 𝔇 ↦↦Cα 𝔇"
    and "x. x  𝔇Obj  universal_arrow_fo 𝔉 x (𝔊ObjMapx) (εNTMapx)"
  shows "cf_adjunction_of_counit α 𝔉 𝔊 ε : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "εC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = ε"
    and "𝒟 (cf_adjunction_of_counit α 𝔉 𝔊 εAdjNTNTMap) = 
      (op_cat  ×C 𝔇)Obj"
    and "c d.  c  Obj; d  𝔇Obj  
      cf_adjunction_of_counit α 𝔉 𝔊 εAdjNTNTMapc, d =
        (umap_fo 𝔉 d (𝔊ObjMapd) (εNTMapd) c)¯Set"
proof-

  interpret: category α  by (rule assms(1))
  interpret 𝔇: category α 𝔇 by (rule assms(2))
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(3))
  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(4))
  interpret ε: is_ntcf α 𝔇 𝔇 𝔉 CF 𝔊 ‹cf_id 𝔇 ε by (rule assms(5))
  
  note cf_adjunction_of_counit_def' = 
    cf_adjunction_of_counit_def[where 𝔉=𝔉, unfolded 𝔉.cf_HomDom 𝔉.cf_HomCod]
  
  have ua:
    "universal_arrow_of (op_cf 𝔉) x (op_cf 𝔊ObjMapx) (op_ntcf εNTMapx)"
    if "x  op_cat 𝔇Obj" for x
    using that unfolding cat_op_simps by (rule assms(6))
  
  let ?aou = ‹cf_adjunction_of_unit α (op_cf 𝔊) (op_cf 𝔉) (op_ntcf ε)
  from 
    cf_adjunction_of_unit_is_cf_adjunction
      [
        OF 
          𝔇.category_op
          ℭ.category_op
          𝔊.is_functor_op
          𝔉.is_functor_op
          ε.is_ntcf_op[unfolded cat_op_simps]
          ua,
        simplified cf_adjunction_of_counit_def[symmetric]
      ]
  have aou: "?aou : op_cf 𝔊 CF op_cf 𝔉 : op_cat 𝔇 ⇌⇌Cα op_cat "
    and η_aou: "ηC ?aou = op_ntcf ε"
    by auto
  interpret aou: 
    is_cf_adjunction α ‹op_cat 𝔇 ‹op_cat  ‹op_cf 𝔊 ‹op_cf 𝔉 ?aou
    by (rule aou)
  from η_aou have
    "op_ntcf (ηC ?aou) = op_ntcf (op_ntcf ε)"
    by simp
  then show "εC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = ε"
    unfolding 
      ε.ntcf_op_ntcf_op_ntcf
      is_cf_adjunction.op_ntcf_cf_adjunction_unit[OF aou]
      cf_adjunction_of_counit_def'[symmetric]
    by (simp add: cat_op_simps)
  show aoc_ε: "cf_adjunction_of_counit α 𝔉 𝔊 ε : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    by 
      (
        rule 
          is_cf_adjunction_op[
            OF aou, folded cf_adjunction_of_counit_def', unfolded cat_op_simps
          ]
      )
  interpret aoc_ε: is_cf_adjunction α  𝔇 𝔉 𝔊 ‹cf_adjunction_of_counit α 𝔉 𝔊 ε
    by (rule aoc_ε)

  from aoc_ε.NT.is_ntcf_axioms show
    "𝒟 (cf_adjunction_of_counit α 𝔉 𝔊 εAdjNTNTMap) = (op_cat  ×C 𝔇)Obj"
    by (cs_concl cs_simp: cat_cs_simps)

  show "c d.  c  Obj; d  𝔇Obj  
    cf_adjunction_of_counit α 𝔉 𝔊 εAdjNTNTMapc, d =
      (umap_fo 𝔉 d (𝔊ObjMapd) (εNTMapd) c)¯Set"
  proof-
    fix c d assume prems: "c  Obj" "d  𝔇Obj"
    from assms(1-4) prems have aou_dc:
      "cf_adjunction_AdjNT_of_unit 
        α (op_cf 𝔊) (op_cf 𝔉) (op_ntcf ε)NTMapd, c =
        umap_fo 𝔉 d (𝔊ObjMapd) (εNTMapd) c"
      by (cs_concl cs_simp: cat_op_simps adj_cs_simps cs_intro: cat_op_intros)
    from assms(1-4) aou prems have ufo_ε_dc:
      "umap_fo 𝔉 d (𝔊ObjMapd) (εNTMapd) c :
        HomO.Cαop_cat (op_cf 𝔊-,-)ObjMapd, c isocat_Set α
        HomO.Cαop_cat 𝔇(-,op_cf 𝔉-)ObjMapd, c"
      by 
        (
          cs_concl 
            cs_simp: 
              aou_dc[symmetric] cf_adjunction_of_unit_components(3)[symmetric]
            cs_intro: 
              is_iso_ntcf.iso_ntcf_is_arr_isomorphism' 
              adj_cs_intros 
              cat_cs_intros 
              cat_op_intros
              cat_prod_cs_intros
        )
    from 
      assms(1-4) 
      aoc_ε[unfolded cf_adjunction_of_counit_def'] 
      aou 
      prems 
      ufo_ε_dc
    show
      "cf_adjunction_of_counit α 𝔉 𝔊 εAdjNTNTMapc, d =
        (umap_fo 𝔉 d (𝔊ObjMapd) (εNTMapd) c)¯Set"
      unfolding cf_adjunction_of_counit_def'
      by 
        ( 
          cs_concl 
            cs_simp: cat_op_simps adj_cs_simps cat_cs_simps cat_Set_cs_simps 
            cs_intro: adj_cs_intros cat_cs_intros cat_prod_cs_intros
        )
  qed

qed



subsection‹
Construction of an adjunction from a functor and universal morphisms
from functors to objects
›


text‹
The subsection presents the construction of an adjunction given 
a functor and a structured collection of universal morphisms 
from functors to objects.
The content of this subsection follows the statement and the proof
of Theorem 2-iv in Chapter IV-1 in \cite{mac_lane_categories_2010}.
›


subsubsection‹Definition and elementary properties›

definition cf_ra_of_la :: "(V  V)  V  V  V"
  where "cf_ra_of_la F 𝔉 ε = op_cf (cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε))"


subsubsection‹Object map›

lemma cf_ra_of_la_ObjMap_vsv[adj_cs_intros]: "vsv (cf_ra_of_la F 𝔉 εObjMap)"
  unfolding cf_ra_of_la_def op_cf_components by (auto intro: adj_cs_intros)

lemma (in is_functor) cf_ra_of_la_ObjMap_vdomain: 
  "𝒟 (cf_ra_of_la F 𝔉 εObjMap) = 𝔅Obj"
  unfolding cf_ra_of_la_def cf_la_of_ra_components cat_op_simps 
  by (simp add: cat_cs_simps)

lemmas [adj_cs_simps] = is_functor.cf_ra_of_la_ObjMap_vdomain

lemma (in is_functor) cf_ra_of_la_ObjMap_app: 
  assumes "d  𝔅Obj"
  shows "cf_ra_of_la F 𝔉 εObjMapd = F d"
  using assms 
  unfolding cf_ra_of_la_def cf_la_of_ra_components cat_op_simps
  by (simp add: cat_cs_simps)

lemmas [adj_cs_simps] = is_functor.cf_ra_of_la_ObjMap_app


subsubsection‹Arrow map›

lemma cf_ra_of_la_ArrMap_app_unique:
  assumes "𝔉 :  ↦↦Cα 𝔇"
    and "f : a 𝔇 b"
    and "universal_arrow_fo 𝔉 a (cf_ra_of_la F 𝔉 εObjMapa) (εNTMapa)"
    and "universal_arrow_fo 𝔉 b (cf_ra_of_la F 𝔉 εObjMapb) (εNTMapb)"
  shows "cf_ra_of_la F 𝔉 εArrMapf : F a  F b"
    and "f A𝔇 εNTMapa =
      umap_fo 𝔉 b (F b) (εNTMapb) (F a)ArrValcf_ra_of_la F 𝔉 εArrMapf"
    and "f'.
      
        f' : F a  F b;
        f A𝔇 εNTMapa = umap_fo 𝔉 b (F b) (εNTMapb) (F a)ArrValf'
        cf_ra_of_la F 𝔉 εArrMapf = f'"
proof-
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(1))
  from assms(2) have op_f: "f : b op_cat 𝔇 a" unfolding cat_op_simps by simp
  let ?lara = ‹cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε)
  have lara_ObjMap_eq_op: "?laraObjMap = (op_cf ?laraObjMap)"
    and lara_ArrMap_eq_op: "?laraArrMap = (op_cf ?laraArrMap)"
    unfolding cat_op_simps by simp_all
  note ua_η_a = 𝔉.universal_arrow_foD[OF assms(3)]
    and ua_η_b = 𝔉.universal_arrow_foD[OF assms(4)]
  from assms(1,2) ua_η_a(2) have [cat_op_simps]:
    "εNTMapa Aop_cat 𝔇 f = f A𝔇 εNTMapa"
    by (cs_concl cs_simp: cat_cs_simps cat_op_simps)
  show "cf_ra_of_la F 𝔉 εArrMapf : F a  F b"
    and "f A𝔇 εNTMapa =
      umap_fo 𝔉 b (F b) (εNTMapb) (F a)ArrValcf_ra_of_la F 𝔉 εArrMapf"
    and "f'.
      
        f' : F a  F b;
        f A𝔇 εNTMapa = umap_fo 𝔉 b (F b) (εNTMapb) (F a)ArrValf'
        cf_ra_of_la F 𝔉 εArrMapf = f'"
    by 
      (
        intro 
          cf_la_of_ra_ArrMap_app_unique
            [
              where η=‹op_ntcf ε and F=F,
                OF 𝔉.is_functor_op op_f, 
                unfolded 
                  𝔉.op_cf_universal_arrow_of 
                  lara_ObjMap_eq_op
                  lara_ArrMap_eq_op,
                folded cf_ra_of_la_def,
                unfolded cat_op_simps,
                OF assms(4,3)
            ]
      )+
qed

lemma cf_ra_of_la_ArrMap_app_is_arr[adj_cs_intros]:
  assumes "𝔉 :  ↦↦Cα 𝔇"
    and "f : a 𝔇 b"
    and "universal_arrow_fo 𝔉 a (cf_ra_of_la F 𝔉 εObjMapa) (εNTMapa)"
    and "universal_arrow_fo 𝔉 b (cf_ra_of_la F 𝔉 εObjMapb) (εNTMapb)"
    and "Fa = F a"
    and "Fb = F b"
  shows "cf_ra_of_la F 𝔉 εArrMapf : Fa  Fb"
  using assms(1-4) unfolding assms(5,6) by (rule cf_ra_of_la_ArrMap_app_unique)


subsubsection‹
An adjunction constructed from a functor and universal morphisms 
from functors to objects is an adjunction
›

lemma op_cf_cf_la_of_ra_op[cat_op_simps]: 
  "op_cf (cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε)) = cf_ra_of_la F 𝔉 ε"
  unfolding cf_ra_of_la_def by simp

lemma cf_ra_of_la_commute_op:
  assumes "𝔉 :  ↦↦Cα 𝔇"
    and "d. d  𝔇Obj 
      universal_arrow_fo 𝔉 d (cf_ra_of_la F 𝔉 εObjMapd) (εNTMapd)"
    and "d d' h. h : d 𝔇 d' 
      εNTMapd' A𝔇 𝔉ArrMapcf_ra_of_la F 𝔉 εArrMaph =
        h A𝔇 εNTMapd"
    and "h : c' 𝔇 c"
  shows "𝔉ArrMapcf_ra_of_la F 𝔉 εArrMaph Aop_cat 𝔇 εNTMapc =
    εNTMapc' Aop_cat 𝔇 h"
proof-
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(1))
  from assms(4) have c': "c'  𝔇Obj" and c: "c  𝔇Obj" by auto
  note ua_η_c' = 𝔉.universal_arrow_foD[OF assms(2)[OF c']]
    and ua_η_c = 𝔉.universal_arrow_foD[OF assms(2)[OF c]]
  note rala_f = cf_ra_of_la_ArrMap_app_unique[
      OF assms(1) assms(4) assms(2)[OF c'] assms(2)[OF c]
      ]
  from assms(1) assms(4) ua_η_c'(2) ua_η_c(2) rala_f(1) show ?thesis
    by 
      (
        cs_concl 
          cs_simp: assms(3) cat_op_simps adj_cs_simps cat_cs_simps 
          cs_intro: cat_cs_intros
      )
qed

lemma 
  assumes "𝔉 :  ↦↦Cα 𝔇"
    and "d. d  𝔇Obj  F d  Obj"
    and "d. d  𝔇Obj 
      universal_arrow_fo 𝔉 d (cf_ra_of_la F 𝔉 εObjMapd) (εNTMapd)"
    and "d d' h. h : d 𝔇 d' 
      εNTMapd' A𝔇 𝔉ArrMapcf_ra_of_la F 𝔉 εArrMaph =
        h A𝔇 εNTMapd"
  shows cf_ra_of_la_is_functor: "cf_ra_of_la F 𝔉 ε : 𝔇 ↦↦Cα "
    and cf_la_of_ra_op_is_functor:  
      "cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε) : op_cat 𝔇 ↦↦Cα op_cat "
proof-
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(1))
  have 𝔉h_εc:
    "𝔉ArrMapcf_ra_of_la F 𝔉 εArrMaph Aop_cat 𝔇 εNTMapc =
      εNTMapc' Aop_cat 𝔇 h"
    if "h : c' 𝔇 c" for c c' h
  proof-
    from that have c': "c'  𝔇Obj" and c: "c  𝔇Obj" by auto
    note ua_η_c' = 𝔉.universal_arrow_foD[OF assms(3)[OF c']]
      and ua_η_c = 𝔉.universal_arrow_foD[OF assms(3)[OF c]]
    note rala_f = cf_ra_of_la_ArrMap_app_unique[
        OF assms(1) that assms(3)[OF c'] assms(3)[OF c]
        ]
    from assms(1) that ua_η_c'(2) ua_η_c(2) rala_f(1) show ?thesis
      by 
        (
          cs_concl 
            cs_simp: assms(4) cat_op_simps adj_cs_simps cat_cs_simps 
            cs_intro: cat_cs_intros
        )
  qed
  let ?lara = ‹cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε)
  have lara_ObjMap_eq_op: "?laraObjMap = (op_cf ?laraObjMap)"
    and lara_ArrMap_eq_op: "?laraArrMap = (op_cf ?laraArrMap)"
    by (simp_all add: cat_op_simps del: op_cf_cf_la_of_ra_op)
  show "cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε) : op_cat 𝔇 ↦↦Cα op_cat "
    by 
      (
        intro cf_la_of_ra_is_functor
          [
            where F=F and η=‹op_ntcf ε,
            OF 𝔉.is_functor_op,
            unfolded cat_op_simps,
            OF assms(2),
            simplified,
            unfolded lara_ObjMap_eq_op lara_ArrMap_eq_op,
            folded cf_ra_of_la_def,
            OF assms(3) 𝔉h_εc
         ]
      )
  from 
    is_functor.is_functor_op[
      OF this, unfolded cat_op_simps, folded cf_ra_of_la_def
      ]
  show "cf_ra_of_la F 𝔉 ε : 𝔇 ↦↦Cα ".
qed

lemma cf_ra_of_la_is_ntcf:  
  fixes F 𝔉 ε
  defines "𝔊  cf_ra_of_la F 𝔉 ε"
  assumes "𝔉 :  ↦↦Cα 𝔇"
    and "d. d  𝔇Obj  F d  Obj"
    and "d. d  𝔇Obj 
      universal_arrow_fo 𝔉 d (𝔊ObjMapd) (εNTMapd)"
    and "d d' h. h : d 𝔇 d' 
      εNTMapd' A𝔇 𝔉ArrMap𝔊ArrMaph = h A𝔇 εNTMapd"
    and "vfsequence ε"
    and "vcard ε = 5"
    and "εNTDom = 𝔉 CF 𝔊"
    and "εNTCod = cf_id 𝔇"
    and "εNTDGDom = 𝔇"
    and "εNTDGCod = 𝔇"
    and "vsv (εNTMap)"
    and "𝒟 (εNTMap) = 𝔇Obj"
  shows "ε : 𝔉 CF 𝔊 CF cf_id 𝔇 : 𝔇 ↦↦Cα 𝔇"
proof-

  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(2))
  interpret 𝔊: is_functor α 𝔇  𝔊 
    unfolding 𝔊_def
    by (auto intro: cf_ra_of_la_is_functor[OF assms(2-5)[unfolded assms(1)]])
  interpret op_ε: is_functor 
    α ‹op_cat 𝔇 ‹op_cat  ‹cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε)
    by 
      (
        intro cf_la_of_ra_op_is_functor[
          where F=F and ε=ε, OF assms(2,3,4,5)[unfolded 𝔊_def], simplified
          ]
      )
  interpret ε: vfsequence ε by (rule assms(6))

  have [cat_op_simps]: "op_ntcf (op_ntcf ε) = ε"
  proof(rule vsv_eqI)
    have dom_lhs: "𝒟 (op_ntcf (op_ntcf ε)) = 5"
      unfolding op_ntcf_def by (simp add: nat_omega_simps)
    from assms(7) show "𝒟 (op_ntcf (op_ntcf ε)) = 𝒟 ε" 
      by (simp add: dom_lhs ε.vfsequence_vdomain)   
    have sup: 
      "op_ntcf (op_ntcf ε)NTDom = εNTDom" 
      "op_ntcf (op_ntcf ε)NTCod = εNTCod" 
      "op_ntcf (op_ntcf ε)NTDGDom = εNTDGDom" 
      "op_ntcf (op_ntcf ε)NTDGCod = εNTDGCod" 
      unfolding op_ntcf_components assms(8-11) cat_op_simps
      by simp_all
    show "a  𝒟 (op_ntcf (op_ntcf ε))  op_ntcf (op_ntcf ε)a = εa" for a
      by (unfold dom_lhs, elim_in_numeral, fold nt_field_simps, unfold sup)
        (simp_all add: cat_op_simps)
  qed (auto simp: op_ntcf_def)

  let ?lara = ‹cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε)
  have lara_ObjMap_eq_op: "?laraObjMap = (op_cf ?laraObjMap)"
    and lara_ArrMap_eq_op: "?laraArrMap = (op_cf ?laraArrMap)"
    by (simp_all add: cat_op_simps del: op_cf_cf_la_of_ra_op)

  have seq: "vfsequence (op_ntcf ε)" unfolding op_ntcf_def by auto
  have card: "vcard (op_ntcf ε) = 5" 
    unfolding op_ntcf_def by (simp add: nat_omega_simps)
  have op_cf_NTCod: "op_cf (εNTCod) = cf_id (op_cat 𝔇)"
    unfolding assms(9) cat_op_simps by simp

  from assms(2) have op_cf_NTDom:
    "op_cf (εNTDom) = op_cf 𝔉 CF cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε)"
    unfolding assms(8) cat_op_simps 𝔊_def 
    by (simp_all add: cat_op_simps cf_ra_of_la_def del: op_cf_cf_la_of_ra_op)
  have "op_ntcf ε :
    cf_id (op_cat 𝔇) CF op_cf 𝔉 CF cf_la_of_ra F (op_cf 𝔉) (op_ntcf ε) :
    op_cat 𝔇 ↦↦Cα op_cat 𝔇"
    by 
      (
        auto intro: cf_la_of_ra_is_ntcf
          [
            where F=F and η=‹op_ntcf ε,
            OF is_functor.is_functor_op[OF assms(2)],
            unfolded cat_op_simps,
            OF assms(3),
            simplified,
            unfolded 
              lara_ObjMap_eq_op 
              lara_ArrMap_eq_op 
              cf_ra_of_la_def[symmetric],
            OF assms(4)[unfolded 𝔊_def],
            simplified,
            OF cf_ra_of_la_commute_op[
              OF assms(2,4,5)[unfolded 𝔊_def], simplified
              ],
            simplified,
            OF seq card _ op_cf_NTDom _ _ assms(12),
            unfolded assms(8-11,13) cat_op_simps
          ]
      )
  from is_ntcf.is_ntcf_op[OF this, unfolded cat_op_simps 𝔊_def[symmetric]] show 
    "ε : 𝔉 CF 𝔊 CF cf_id 𝔇 : 𝔇 ↦↦Cα 𝔇".

qed

lemma cf_ra_of_la_is_counit: 
  fixes F 𝔉 ε
  defines "𝔊  cf_ra_of_la F 𝔉 ε"
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "d. d  𝔇Obj  F d  Obj"
    and "d. d  𝔇Obj 
      universal_arrow_fo 𝔉 d (𝔊ObjMapd) (εNTMapd)"
    and "d d' h. h : d 𝔇 d' 
      εNTMapd' A𝔇 𝔉ArrMap𝔊ArrMaph = h A𝔇 εNTMapd"
    and "vfsequence ε"
    and "vcard ε = 5"
    and "εNTDom = 𝔉 CF 𝔊"
    and "εNTCod = cf_id 𝔇"
    and "εNTDGDom = 𝔇"
    and "εNTDGCod = 𝔇"
    and "vsv (εNTMap)"
    and "𝒟 (εNTMap) = 𝔇Obj"
  shows "cf_adjunction_of_counit α 𝔉 𝔊 ε : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "εC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = ε"
proof-
  note 𝔉 = cf_ra_of_la_is_functor[
    where F=F and ε=ε, OF assms(4-7)[unfolded 𝔊_def], simplified
    ]
  note ε = cf_ra_of_la_is_ntcf[OF assms(4-15)[unfolded 𝔊_def], simplified]
  show "cf_adjunction_of_counit α 𝔉 𝔊 ε : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "εC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = ε"
    by 
      (
        intro 
          cf_adjunction_of_counit_is_cf_adjunction
            [
              OF assms(2,3,4) 𝔉 ε assms(6)[unfolded 𝔊_def], 
              simplified, 
              folded 𝔊_def
            ]
      )+
qed



subsection‹Construction of an adjunction from the counit-unit equations›


text‹
The subsection presents the construction of an adjunction given 
two natural transformations satisfying counit-unit equations.
The content of this subsection follows the statement and the proof
of Theorem 2-v in Chapter IV-1 in \cite{mac_lane_categories_2010}.
›

lemma counit_unit_is_cf_adjunction:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
    and "ε : 𝔉 CF 𝔊 CF cf_id 𝔇 : 𝔇 ↦↦Cα 𝔇"
    and "(𝔊 CF-NTCF ε) NTCF (η NTCF-CF 𝔊) = ntcf_id 𝔊"
    and "(ε NTCF-CF 𝔉) NTCF (𝔉 CF-NTCF η) = ntcf_id 𝔉"
  shows "cf_adjunction_of_unit α 𝔉 𝔊 η : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η) = η"
    and "εC (cf_adjunction_of_unit α 𝔉 𝔊 η) = ε"
proof-

  interpret: category α  by (rule assms(1))
  interpret 𝔇: category α 𝔇 by (rule assms(2))
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(3))
  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(4))
  interpret η: is_ntcf α   ‹cf_id  𝔊 CF 𝔉 η by (rule assms(5))
  interpret ε: is_ntcf α 𝔇 𝔇 𝔉 CF 𝔊 ‹cf_id 𝔇 ε by (rule assms(6))

  have 𝔊εx_η𝔊x[cat_cs_simps]:
    "𝔊ArrMapεNTMapx A ηNTMap𝔊ObjMapx = CId𝔊ObjMapx"
    if "x  𝔇Obj" for x
  proof-
    from assms(7) have 
      "((𝔊 CF-NTCF ε) NTCF (η NTCF-CF 𝔊))NTMapx = ntcf_id 𝔊NTMapx"
      by simp
    from this assms(1-6) that show 
      "𝔊ArrMapεNTMapx A ηNTMap𝔊ObjMapx = 
        CId𝔊ObjMapx"
      by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  qed
  have [cat_cs_simps]:
    "𝔊ArrMapεNTMapx A (ηNTMap𝔊ObjMapx A f) =
      CId𝔊ObjMapx A f"
    if "x  𝔇Obj" and "f : a  𝔊ObjMapx" for x f a
    using assms(1-6) that
    by (intro ℭ.cat_assoc_helper)
      (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

  have [cat_cs_simps]:
    "εNTMap𝔉ObjMapx A𝔇 𝔉ArrMapηNTMapx = 𝔇CId𝔉ObjMapx"
    if "x  Obj" for x
  proof-
    from assms(8) have 
      "((ε NTCF-CF 𝔉) NTCF (𝔉 CF-NTCF η))NTMapx = ntcf_id 𝔉NTMapx"
      by simp
    from this assms(1-6) that show
      "εNTMap𝔉ObjMapx A𝔇 𝔉ArrMapηNTMapx = 𝔇CId𝔉ObjMapx"
      by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  qed

  have ua_𝔉x_ηx: "universal_arrow_of 𝔊 x (𝔉ObjMapx) (ηNTMapx)"
    if "x  Obj" for x 
  proof(intro is_functor.universal_arrow_ofI)
    from assms(3) that show "𝔉ObjMapx  𝔇Obj"
      by (cs_concl cs_intro: cat_cs_intros)
    from assms(3-6) that show "ηNTMapx : x  𝔊ObjMap𝔉ObjMapx"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    fix r' u' assume prems': "r'  𝔇Obj" "u' : x  𝔊ObjMapr'"
    show "∃!f'.
      f' : 𝔉ObjMapx 𝔇 r' 
      u' = umap_of 𝔊 x (𝔉ObjMapx) (ηNTMapx) r'ArrValf'"
    proof(intro ex1I conjI; (elim conjE)?)
      from assms(3-6) that prems' show 
        "εNTMapr' A𝔇 𝔉ArrMapu' : 𝔉ObjMapx 𝔇 r'"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      from assms(3-6) prems' have 𝔊𝔉u':
        "(𝔊 CF 𝔉)ArrMapu' = 𝔊ArrMap𝔉ArrMapu'"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      note [cat_cs_simps] = 
        η.ntcf_Comp_commute[symmetric, OF prems'(2), unfolded 𝔊𝔉u']
      from assms(3-6) that prems' show 
        "u' =
          umap_of 𝔊 x (𝔉ObjMapx) (ηNTMapx) r'ArrValεNTMapr' A𝔇
          𝔉ArrMapu'"
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
          )
      fix f' assume prems'':
        "f' : 𝔉ObjMapx 𝔇 r'"
        "u' = umap_of 𝔊 x (𝔉ObjMapx) (ηNTMapx) r'ArrValf'" 
      from prems''(2,1) assms(3-6) that have u'_def:
        "u' = 𝔊ArrMapf' A ηNTMapx"
        by 
          (
            cs_prems 
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
          )
      from 
        ε.ntcf_Comp_commute[OF prems''(1)] 
        assms(3-6) 
        prems''(1) 
      have [cat_cs_simps]:
        "εNTMapr' A𝔇 𝔉ArrMap𝔊ArrMapf' =
          f' A𝔇 εNTMap𝔉ObjMapx"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      have [cat_cs_simps]:
        "εNTMapr' A𝔇 (𝔉ArrMap𝔊ArrMapf' A𝔇 f) =
          (f' A𝔇 εNTMap𝔉ObjMapx) A𝔇 f"
        if "f : a 𝔇 𝔉ObjMap𝔊ObjMap𝔉ObjMapx" for f a
        using assms(1-6) prems''(1) prems' that
        by (intro 𝔇.cat_assoc_helper)
          (
            cs_concl 
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
          )+
      from prems''(2,1) assms(3-6) that show 
        "f' = εNTMapr' A𝔇 𝔉ArrMapu'"
        unfolding u'_def 
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
  qed (auto intro: cat_cs_intros)

  show aou: "cf_adjunction_of_unit α 𝔉 𝔊 η : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    by (intro cf_adjunction_of_unit_is_cf_adjunction ua_𝔉x_ηx assms(1-5))
  from ℭ.category_axioms 𝔇.category_axioms show "ηC (cf_adjunction_of_unit α 𝔉 𝔊 η) = η"
    by (cs_concl cs_intro: cf_adjunction_of_unit_is_cf_adjunction assms(1-5) ua_𝔉x_ηx)

  interpret aou: is_cf_adjunction α  𝔇 𝔉 𝔊 ‹cf_adjunction_of_unit α 𝔉 𝔊 η
    by (rule aou)

  show "εC (cf_adjunction_of_unit α 𝔉 𝔊 η) = ε"
  proof(rule ntcf_eqI)
    show ε_η: "εC (cf_adjunction_of_unit α 𝔉 𝔊 η) :
      𝔉 CF 𝔊 CF cf_id 𝔇 : 𝔇 ↦↦Cα 𝔇"
      by (rule aou.cf_adjunction_counit_is_ntcf)
    from assms(1-6) ε_η have dom_lhs:
      "𝒟 (εC (cf_adjunction_of_unit α 𝔉 𝔊 η)NTMap) = 𝔇Obj"
      by (cs_concl cs_simp: cat_cs_simps)
    from assms(1-6) ε_η have dom_rhs: "𝒟 (εNTMap) = 𝔇Obj"
      by (cs_concl cs_simp: cat_cs_simps)
    show "εC (cf_adjunction_of_unit α 𝔉 𝔊 η)NTMap = εNTMap"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume "a  𝔇Obj"
      with aou.is_cf_adjunction_axioms assms(1-6) show 
        "εC (cf_adjunction_of_unit α 𝔉 𝔊 η)NTMapa = εNTMapa"
        by 
          (
            cs_concl
              cs_intro:
                cat_arrow_cs_intros
                cat_op_intros
                cat_cs_intros
                cat_prod_cs_intros
              cs_simp: 
                aou.cf_adj_umap_of_unit'[symmetric]
                cat_Set_the_inverse[symmetric]
                adj_cs_simps cat_cs_simps cat_op_simps
          )
    qed (auto simp: adj_cs_intros)
  qed (auto simp: assms) 

qed

lemma counit_unit_cf_adjunction_of_counit_is_cf_adjunction:
  assumes "category α "
    and "category α 𝔇"
    and "𝔉 :  ↦↦Cα 𝔇"
    and "𝔊 : 𝔇 ↦↦Cα "
    and "η : cf_id  CF 𝔊 CF 𝔉 :  ↦↦Cα "
    and "ε : 𝔉 CF 𝔊 CF cf_id 𝔇 : 𝔇 ↦↦Cα 𝔇"
    and "(𝔊 CF-NTCF ε) NTCF (η NTCF-CF 𝔊) = ntcf_id 𝔊"
    and "(ε NTCF-CF 𝔉) NTCF (𝔉 CF-NTCF η) = ntcf_id 𝔉"
  shows "cf_adjunction_of_counit α 𝔉 𝔊 ε : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    and "ηC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = η"
    and "εC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = ε"
proof-

  interpret: category α  by (rule assms(1))
  interpret 𝔇: category α 𝔇 by (rule assms(2))
  interpret 𝔉: is_functor α  𝔇 𝔉 by (rule assms(3))
  interpret 𝔊: is_functor α 𝔇  𝔊 by (rule assms(4))
  interpret η: is_ntcf α   ‹cf_id  𝔊 CF 𝔉 η by (rule assms(5))
  interpret ε: is_ntcf α 𝔇 𝔇 𝔉 CF 𝔊 ‹cf_id 𝔇 ε by (rule assms(6))

  have unit_op: "cf_adjunction_of_unit α (op_cf 𝔊) (op_cf 𝔉) (op_ntcf ε) :
    op_cf 𝔊 CF op_cf 𝔉 : op_cat 𝔇 ⇌⇌Cα op_cat "
    by (rule counit_unit_is_cf_adjunction(1)[where ε=‹op_ntcf η])
      (
        cs_concl
          cs_simp:
            cat_op_simps cat_cs_simps 
            𝔊.cf_ntcf_id_op_cf
            𝔉.cf_ntcf_id_op_cf
            op_ntcf_ntcf_vcomp[symmetric]
            op_ntcf_ntcf_cf_comp[symmetric]
            op_ntcf_cf_ntcf_comp[symmetric]
            assms(7,8) 
          cs_intro: cat_op_intros cat_cs_intros
      )+
  then show aou: "cf_adjunction_of_counit α 𝔉 𝔊 ε : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
    unfolding cf_adjunction_of_counit_def
    by
      (
        subst 𝔉.cf_op_cf_op_cf[symmetric],
        subst 𝔊.cf_op_cf_op_cf[symmetric],
        subst ℭ.cat_op_cat_op_cat[symmetric],
        subst 𝔇.cat_op_cat_op_cat[symmetric],
        rule is_cf_adjunction_op
      )

  interpret aou: is_cf_adjunction α  𝔇 𝔉 𝔊 ‹cf_adjunction_of_counit α 𝔉 𝔊 ε
    by (rule aou)

  show "ηC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = η"
    unfolding cf_adjunction_of_counit_def
    by (*slow*)
      (
        cs_concl_step is_cf_adjunction.op_ntcf_cf_adjunction_counit[symmetric], 
        rule unit_op, 
        cs_concl_step counit_unit_is_cf_adjunction(3)[where ε=‹op_ntcf η],
        insert ℭ.category_op 𝔇.category_op
      )
      (
        cs_concl
          cs_simp:
            cat_op_simps cat_cs_simps 
            𝔊.cf_ntcf_id_op_cf
            𝔉.cf_ntcf_id_op_cf
            op_ntcf_ntcf_vcomp[symmetric]
            op_ntcf_ntcf_cf_comp[symmetric]
            op_ntcf_cf_ntcf_comp[symmetric]
            assms(7,8) 
          cs_intro: cat_op_intros cat_cs_intros
      )+ 

  show "εC (cf_adjunction_of_counit α 𝔉 𝔊 ε) = ε"
    unfolding cf_adjunction_of_counit_def
    by
      (
        cs_concl_step is_cf_adjunction.op_ntcf_cf_adjunction_unit[symmetric], 
        rule unit_op, 
        cs_concl_step counit_unit_is_cf_adjunction(2)[where ε=‹op_ntcf η],
        insert ℭ.category_op 𝔇.category_op
      )
      (
        cs_concl
          cs_simp:
            cat_op_simps cat_cs_simps 
            𝔊.cf_ntcf_id_op_cf
            𝔉.cf_ntcf_id_op_cf
            op_ntcf_ntcf_vcomp[symmetric]
            op_ntcf_ntcf_cf_comp[symmetric]
            op_ntcf_cf_ntcf_comp[symmetric]
            assms(7,8) 
          cs_intro: cat_op_intros cat_cs_intros
      )+

qed



subsection‹Adjoints are unique up to isomorphism›


text‹
The content of the following subsection is based predominantly on
the statement and the proof of Corollary 1 in 
Chapter IV-1 in \cite{mac_lane_categories_2010}. However, similar 
results can also be found in section 4 in \cite{riehl_category_2016}
and in subsection 2.1 in \cite{bodo_categories_1970}.
›


subsubsection‹Definitions and elementary properties›

definition cf_adj_LR_iso :: "V  V  V  V  V  V  V  V"
  where "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' Ψ =
    [
      (
        λxObj. THE f'.
        let
          η = ηC Φ;
          η' = ηC Ψ;
          𝔉x = 𝔉ObjMapx;
          𝔉'x = 𝔉'ObjMapx
        in
          f' : 𝔉x 𝔇 𝔉'x 
          η'NTMapx = umap_of 𝔊 x (𝔉x) (ηNTMapx) (𝔉'x)ArrValf'
      ),
      𝔉,
      𝔉',
      ,
      𝔇
    ]"

definition cf_adj_RL_iso :: "V  V  V  V  V  V  V  V"
  where "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ =
    [
      (
        λx𝔇Obj. THE f'.
        let
          ε = εC Φ;
          ε' = εC Ψ;
          𝔊x = 𝔊ObjMapx;
          𝔊'x = 𝔊'ObjMapx
        in
          f' : 𝔊'x  𝔊x 
          ε'NTMapx = umap_fo 𝔉 x 𝔊x (εNTMapx) 𝔊'xArrValf'
      ),
      𝔊',
      𝔊,
      𝔇,
      
    ]"


text‹Components.›

lemma cf_adj_LR_iso_components:
  shows "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTMap =
    (
      λxObj. THE f'.
      let
        η = ηC Φ;
        η' = ηC Ψ;
        𝔉x = 𝔉ObjMapx;
        𝔉'x = 𝔉'ObjMapx
      in
        f' : 𝔉x 𝔇 𝔉'x 
        η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf'
    )"
    and [adj_cs_simps]: "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTDom = 𝔉"
    and [adj_cs_simps]: "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTCod = 𝔉'"
    and [adj_cs_simps]: "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTDGDom = "
    and [adj_cs_simps]: "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTDGCod = 𝔇"
  unfolding cf_adj_LR_iso_def nt_field_simps
  by (simp_all add: nat_omega_simps) (*slow*)

lemma cf_adj_RL_iso_components:
  shows "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTMap =
    (
        λx𝔇Obj. THE f'.
        let
          ε = εC Φ;
          ε' = εC Ψ;
          𝔊x = 𝔊ObjMapx;
          𝔊'x = 𝔊'ObjMapx
        in
          f' : 𝔊'x  𝔊x 
          ε'NTMapx = umap_fo 𝔉 x 𝔊x (εNTMapx) 𝔊'xArrValf'
    )"
    and [adj_cs_simps]: "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTDom = 𝔊'"
    and [adj_cs_simps]: "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTCod = 𝔊"
    and [adj_cs_simps]: "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTDGDom = 𝔇"
    and [adj_cs_simps]: "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTDGCod = "
  unfolding cf_adj_RL_iso_def nt_field_simps
  by (simp_all add: nat_omega_simps) (*slow*)


subsubsection‹Natural transformation map›

lemma cf_adj_LR_iso_vsv[adj_cs_intros]: 
  "vsv (cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTMap)"
  unfolding cf_adj_LR_iso_components by simp

lemma cf_adj_RL_iso_vsv[adj_cs_intros]: 
  "vsv (cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTMap)"
  unfolding cf_adj_RL_iso_components by simp

lemma cf_adj_LR_iso_vdomain[adj_cs_simps]:
  "𝒟 (cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTMap) = Obj"
  unfolding cf_adj_LR_iso_components by simp

lemma cf_adj_RL_iso_vdomain[adj_cs_simps]:
  "𝒟 (cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTMap) = 𝔇Obj"
  unfolding cf_adj_RL_iso_components by simp

lemma cf_adj_LR_iso_app:
  fixes  𝔇 𝔊 𝔉 Φ 𝔉' Ψ
  assumes "x  Obj"
  defines "𝔉x  𝔉ObjMapx"
    and "𝔉'x  𝔉'ObjMapx"
    and "η  ηC Φ" 
    and "η'  ηC Ψ"
  shows "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTMapx =
    (
      THE f'.
        f' : 𝔉x 𝔇 𝔉'x 
        η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf'
    )"
  using assms(1) unfolding cf_adj_LR_iso_components assms(2-5) by simp meson

lemma cf_adj_RL_iso_app:
  fixes  𝔇 𝔉 𝔊 Φ 𝔊' Ψ
  assumes "x  𝔇Obj"
  defines "𝔊x  𝔊ObjMapx"
    and "𝔊'x  𝔊'ObjMapx"
    and "ε  εC Φ" 
    and "ε'  εC Ψ"
  shows "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTMapx =
    (
      THE f'.
        f' : 𝔊'x  𝔊x 
        ε'NTMapx = umap_fo 𝔉 x 𝔊x (εNTMapx) 𝔊'xArrValf'
    )"
  using assms(1) unfolding cf_adj_RL_iso_components assms(2-5) Let_def by simp

lemma cf_adj_LR_iso_app_unique:
  fixes  𝔇 𝔊 𝔉 Φ 𝔉' Ψ
  assumes "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇" 
    and "Ψ : 𝔉' CF 𝔊 :  ⇌⇌Cα 𝔇" 
    and "x  Obj"
  defines "𝔉x  𝔉ObjMapx"
    and "𝔉'x  𝔉'ObjMapx"
    and "η  ηC Φ" 
    and "η'  ηC Ψ"
    and "f  cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' ΨNTMapx"
  shows
    "∃!f'.
      f' : 𝔉x 𝔇 𝔉'x 
      η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf'"
    "f : 𝔉x iso𝔇 𝔉'x"
    "η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf"
proof-
  interpret Φ: is_cf_adjunction α  𝔇 𝔉 𝔊 Φ by (rule assms(1))
  interpret Ψ: is_cf_adjunction α  𝔇 𝔉' 𝔊 Ψ by (rule assms(2))
  note 𝔉a_η =
    is_cf_adjunction.cf_adjunction_unit_component_is_ua_of[
      OF assms(1) assms(3), folded assms(4-8)
      ]
  note 𝔉'a_η = 
    is_cf_adjunction.cf_adjunction_unit_component_is_ua_of[
      OF assms(2) assms(3), folded assms(4-8)
      ]
  from 
    is_functor.cf_universal_arrow_of_unique[
      OF Φ.RL.is_functor_axioms 𝔉a_η 𝔉'a_η, folded assms(4-8)
      ]
  obtain f' 
    where f': "f' : 𝔉x 𝔇 𝔉'x"
      and η'_def: 
        "η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf'"
      and unique_f': 
        "
          f'' : 𝔉x 𝔇 𝔉'x;
          η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf''
          f'' = f'"
    for f''
    by metis
  show unique_f': "∃!f'.
    f' : 𝔉x 𝔇 𝔉'x 
    η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf'"
    by 
      (
        rule is_functor.cf_universal_arrow_of_unique[
          OF Φ.RL.is_functor_axioms 𝔉a_η 𝔉'a_η, folded assms(4-8)
          ]
      )
  from
    theD
      [
        OF unique_f' cf_adj_LR_iso_app[
          OF assms(3), of 𝔇 𝔊 𝔉 Φ 𝔉' Ψ, folded assms(4-8)
          ]
      ]
  have f: "f : 𝔉x 𝔇 𝔉'x"
    and η': "η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf"
    by simp_all
  show "η'NTMapx = umap_of 𝔊 x 𝔉x (ηNTMapx) 𝔉'xArrValf" by (rule η')
  show "f : 𝔉x iso𝔇 𝔉'x"
    by
      (
        rule 
          is_functor.cf_universal_arrow_of_is_arr_isomorphism[
            OF Φ.RL.is_functor_axioms 𝔉a_η 𝔉'a_η f η'
            ]
      )
qed


subsubsection‹Main results›

lemma cf_adj_LR_iso_is_iso_functor:
  ―‹See Corollary 1 in Chapter IV-1 in \cite{mac_lane_categories_2010}.›
  assumes "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇" and "Ψ : 𝔉' CF 𝔊 :  ⇌⇌Cα 𝔇" 
  shows "∃!θ.
    θ : 𝔉 CF 𝔉' :  ↦↦Cα 𝔇 
    ηC Ψ = (𝔊 CF-NTCF θ) NTCF ηC Φ"
    and "cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' Ψ : 𝔉 CF.iso 𝔉' :  ↦↦Cα 𝔇"
    and "ηC Ψ =
      (𝔊 CF-NTCF cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' Ψ) NTCF ηC Φ"
proof-

  interpret Φ: is_cf_adjunction α  𝔇 𝔉 𝔊 Φ by (rule assms(1))
  interpret Ψ: is_cf_adjunction α  𝔇 𝔉' 𝔊 Ψ by (rule assms(2))

  let  = ηC Φ
  let ?η' = ηC Ψ
  let ?ΦΨ = ‹cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' Ψ

  show 𝔉'Ψ: "?ΦΨ : 𝔉 CF.iso 𝔉' :  ↦↦Cα 𝔇"
  proof(intro is_iso_ntcfI is_ntcfI')

    show "vfsequence ?ΦΨ" unfolding cf_adj_LR_iso_def by auto
    show "vcard ?ΦΨ = 5" 
      unfolding cf_adj_LR_iso_def by (simp add: nat_omega_simps)
    show "?ΦΨNTMapa : 𝔉ObjMapa 𝔇 𝔉'ObjMapa"
      if "a  Obj" for a
      using cf_adj_LR_iso_app_unique(2)[OF assms that] by auto

    show "?ΦΨNTMapb A𝔇 𝔉ArrMapf = 𝔉'ArrMapf A𝔇 ?ΦΨNTMapa"
      if "f : a  b" for a b f
    proof-

      from that have a: "a  Obj" and b: "b  Obj" by auto
      note unique_a = cf_adj_LR_iso_app_unique[OF assms a]
      note unique_b = cf_adj_LR_iso_app_unique[OF assms b]

      from unique_a(2) have a_is_arr:
        "?ΦΨNTMapa : 𝔉ObjMapa 𝔇 𝔉'ObjMapa"
        by auto
      from unique_b(2) have b_is_arr:
        "?ΦΨNTMapb : 𝔉ObjMapb 𝔇 𝔉'ObjMapb"
        by auto

      interpret η: is_ntcf α   ‹cf_id  𝔊 CF 𝔉 
        by (rule Φ.cf_adjunction_unit_is_ntcf)
      interpret η': is_ntcf α   ‹cf_id  𝔊 CF 𝔉' ?η'
        by (rule Ψ.cf_adjunction_unit_is_ntcf)

      from unique_a(3) a_is_arr a b have η'_a_def: 
        "?η'NTMapa = 𝔊ArrMap?ΦΨNTMapa A NTMapa"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: adj_cs_intros cat_cs_intros)
      from unique_b(3) b_is_arr a b have η'_b_def:
        "?η'NTMapb = 𝔊ArrMap?ΦΨNTMapb A NTMapb"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: adj_cs_intros cat_cs_intros)
      
      from that a b a_is_arr have 
        "𝔊ArrMap𝔉'ArrMapf A 
          (𝔊ArrMap?ΦΨNTMapa A NTMapa) = 
          𝔊ArrMap𝔉'ArrMapf A ?η'NTMapa"
        by (cs_concl cs_simp: cat_cs_simps η'_a_def cs_intro: cat_cs_intros)
      also from η'.ntcf_Comp_commute[OF that, symmetric] that a b have 
        " = ?η'NTMapb A f"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      also from that a b b_is_arr have
        " = 𝔊ArrMap?ΦΨNTMapb A
          (NTMapb A f)" 
        by (cs_concl cs_simp: cat_cs_simps η'_b_def cs_intro: cat_cs_intros)
      also from that have 
        " = 𝔊ArrMap?ΦΨNTMapb A
          ((𝔊 CF 𝔉)ArrMapf A NTMapa)"
        unfolding η.ntcf_Comp_commute[OF that, symmetric]
        by (cs_concl cs_simp: cat_cs_simps η'_b_def cs_intro: cat_cs_intros)
      also from that b_is_arr have 
        " = 𝔊ArrMap?ΦΨNTMapb A
          (𝔊ArrMap𝔉ArrMapf A NTMapa)"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      finally have [cat_cs_simps]:
        "𝔊ArrMap𝔉'ArrMapf A (𝔊ArrMap?ΦΨNTMapa A 
          NTMapa) =
          𝔊ArrMap?ΦΨNTMapb A
            (𝔊ArrMap𝔉ArrMapf A NTMapa)"
        by simp

      note unique_f_a = is_functor.universal_arrow_ofD
        [
          OF 
            Φ.RL.is_functor_axioms 
            Φ.cf_adjunction_unit_component_is_ua_of[OF a]
        ]

      from that a b a_is_arr b_is_arr have 𝔊𝔉f_ηa:
        "𝔊ArrMap𝔉'ArrMapf  A ?η'NTMapa :
          a  𝔊ObjMap𝔉'ObjMapb"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

      from b have 𝔉'b: "𝔉'ObjMapb  𝔇Obj"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

      from unique_f_a(3)[OF 𝔉'b 𝔊𝔉f_ηa] obtain f' 
        where f': "f' : 𝔉ObjMapa 𝔇 𝔉'ObjMapb"
          and ηa: "𝔊ArrMap𝔉'ArrMapf A ?η'NTMapa =
          umap_of 𝔊 a (𝔉ObjMapa) (NTMapa) (𝔉'ObjMapb)ArrValf'"
          and unique_f':
            "
              f'' : 𝔉ObjMapa 𝔇 𝔉'ObjMapb;
              𝔊ArrMap𝔉'ArrMapf A ?η'NTMapa =
                umap_of 𝔊 a (𝔉ObjMapa) (NTMapa) (𝔉'ObjMapb)ArrValf''
               f'' = f'"
        for f''
        by metis
      have "?ΦΨNTMapb A𝔇 𝔉ArrMapf = f'"
        by (rule unique_f', insert a b a_is_arr b_is_arr that)
          (cs_concl cs_simp: η'_a_def cat_cs_simps cs_intro: cat_cs_intros)
      moreover have "𝔉'ArrMapf A𝔇 ?ΦΨNTMapa = f'"
        by (rule unique_f', insert a b a_is_arr b_is_arr that)
          (cs_concl cs_simp: η'_a_def cat_cs_simps cs_intro: cat_cs_intros)
      ultimately show ?thesis by simp
    qed 

  qed 
    (
      auto 
        intro: cat_cs_intros adj_cs_intros  
        simp: adj_cs_simps cf_adj_LR_iso_app_unique(2)[OF assms]
    )

  interpret 𝔉'Ψ: is_iso_ntcf α  𝔇 𝔉 𝔉' ?ΦΨ by (rule 𝔉'Ψ)

  show η'_def: "?η' = 𝔊 CF-NTCF ?ΦΨ NTCF ηC Φ"
  proof(rule ntcf_eqI)
    have dom_lhs: "𝒟 (?η'NTMap) = Obj"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: adj_cs_intros)
    have dom_rhs: "𝒟 ((𝔊 CF-NTCF ?ΦΨ NTCF ηC Φ)NTMap) = Obj"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: adj_cs_intros cat_cs_intros)
    show "?η'NTMap = (𝔊 CF-NTCF ?ΦΨ NTCF ηC Φ)NTMap"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume prems: "a  Obj"
      note unique_a = cf_adj_LR_iso_app_unique[OF assms prems]
      from unique_a(2) have a_is_arr:
        "?ΦΨNTMapa : 𝔉ObjMapa 𝔇 𝔉'ObjMapa"
        by auto  
      interpret η: is_ntcf α   ‹cf_id  𝔊 CF 𝔉 
        by (rule Φ.cf_adjunction_unit_is_ntcf)
      from unique_a(3) a_is_arr prems have η'_a_def: 
        "?η'NTMapa = 𝔊ArrMap?ΦΨNTMapa A ηC ΦNTMapa"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: adj_cs_intros cat_cs_intros)
      from prems a_is_arr show 
        "?η'NTMapa =  (𝔊 CF-NTCF ?ΦΨ NTCF )NTMapa"
        by (cs_concl cs_simp: η'_a_def cat_cs_simps cs_intro: cat_cs_intros)
    qed (auto intro: cat_cs_intros adj_cs_intros)
  qed (cs_concl cs_simp: cat_cs_simps cs_intro: adj_cs_intros cat_cs_intros)+

  show "∃!θ. θ : 𝔉 CF 𝔉' :  ↦↦Cα 𝔇  ?η' = (𝔊 CF-NTCF θ) NTCF "
  proof(intro ex1I conjI; (elim conjE)?)
    from 𝔉'Ψ show "?ΦΨ : 𝔉 CF 𝔉' :  ↦↦Cα 𝔇" by auto
    show "?η' = 𝔊 CF-NTCF ?ΦΨ NTCF ηC Φ" by (rule η'_def)
    fix θ assume prems:
      "θ : 𝔉 CF 𝔉' :  ↦↦Cα 𝔇"
      "?η' = 𝔊 CF-NTCF θ NTCF ηC Φ"
    interpret θ: is_ntcf α  𝔇 𝔉 𝔉' θ by (rule prems(1))
    from prems have η'_a: 
      "?η'NTMapa = (𝔊 CF-NTCF θ NTCF ηC Φ)NTMapa" 
      for a
      by simp
    have η'a: "ηC ΨNTMapa =
      𝔊ArrMapθNTMapa A ηC ΦNTMapa"
      if "a  Obj" for a
      using η'_a[where a=a] that
      by (cs_prems cs_simp: cat_cs_simps cs_intro: adj_cs_intros cat_cs_intros)
    show "θ = ?ΦΨ"
    proof(rule ntcf_eqI)
      have dom_lhs: "𝒟 (θNTMap) = Obj" by (cs_concl cs_simp: cat_cs_simps)
      have dom_rhs: "𝒟 (?ΦΨNTMap) = Obj"
        by (cs_concl cs_simp: cat_cs_simps)
      show "θNTMap = ?ΦΨNTMap"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
        fix a assume prems': "a  Obj"
        let ?uof = ‹umap_of 𝔊 a (𝔉ObjMapa) (NTMapa) (𝔉'ObjMapa)
        from cf_adj_LR_iso_app_unique[OF assms prems'] obtain f' 
          where f': "f' : 𝔉ObjMapa 𝔇 𝔉'ObjMapa"
            and η_def: "?η'NTMapa = ?uofArrValf'"
            and unique_f': "f''.
              
                f'' : 𝔉ObjMapa 𝔇 𝔉'ObjMapa;
                ?η'NTMapa = ?uofArrValf''
                f'' = f'"
          by metis
        from prems' have θa: "θNTMapa : 𝔉ObjMapa 𝔇 𝔉'ObjMapa"
          by (cs_concl cs_simp: cs_intro: cat_cs_intros)
        from η_def f' prems' have 
          "ηC ΨNTMapa = 𝔊ArrMapf' A ηC ΦNTMapa"
          by 
            (
              cs_prems 
                cs_simp: cat_cs_simps cs_intro: adj_cs_intros cat_cs_intros
            )
        from prems' have "ηC ΨNTMapa = ?uofArrValθNTMapa"
          by 
            (
              cs_concl 
                cs_simp: cat_cs_simps η'a[OF prems'] 
                cs_intro: adj_cs_intros cat_cs_intros
            )
        from unique_f'[OF θa this] have θa: "θNTMapa = f'".
        from prems' have Ψa: 
          "?ΦΨNTMapa : 𝔉ObjMapa 𝔇 𝔉'ObjMapa"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        from prems' have "ηC ΨNTMapa = ?uofArrVal?ΦΨNTMapa"
          by 
            ( 
              cs_concl 
                cs_simp: cf_adj_LR_iso_app_unique(3)[OF assms] cat_cs_simps 
                cs_intro: adj_cs_intros cat_cs_intros
            )
        from unique_f'[OF Ψa this] have 𝔉'Ψ_def: "?ΦΨNTMapa = f'".
        show "θNTMapa = ?ΦΨNTMapa" unfolding θa 𝔉'Ψ_def ..
      qed auto
    qed (cs_concl cs_simp: cs_intro: cat_cs_intros)+
  qed

qed

lemma op_ntcf_cf_adj_RL_iso[cat_op_simps]:
  assumes "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇" 
    and "Ψ : 𝔉 CF 𝔊' :  ⇌⇌Cα 𝔇" 
  defines "op_𝔇  op_cat 𝔇"
    and "op_ℭ  op_cat "
    and "op_𝔉  op_cf 𝔉"
    and "op_𝔊  op_cf 𝔊"
    and "op_Φ  op_cf_adj Φ"
    and "op_𝔊'  op_cf 𝔊'"
    and "op_Ψ  op_cf_adj Ψ"
  shows
    "op_ntcf (cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ) =
      cf_adj_LR_iso op_𝔇 op_ℭ op_𝔉 op_𝔊 op_Φ op_𝔊' op_Ψ"
proof-
  interpret Φ: is_cf_adjunction α  𝔇 𝔉 𝔊 Φ by (rule assms(1))
  interpret Ψ: is_cf_adjunction α  𝔇 𝔉 𝔊' Ψ by (rule assms(2))
  interpret ε: is_ntcf α 𝔇 𝔇 𝔉 CF 𝔊 ‹cf_id 𝔇 εC Φ
    by (rule Φ.cf_adjunction_counit_is_ntcf)
  have dom_lhs: "𝒟 (op_ntcf (cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ)) = 5"
    unfolding op_ntcf_def by (simp add: nat_omega_simps)
  show ?thesis
  proof(rule vsv_eqI, unfold dom_lhs)
    fix a assume prems: "a  5"
    then have "a  5" unfolding dom_lhs by simp
    then show 
      "op_ntcf (cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ)a =
        cf_adj_LR_iso op_𝔇 op_ℭ op_𝔉 op_𝔊 op_Φ op_𝔊' op_Ψa"
      by 
        (
          elim_in_numeral, 
          fold nt_field_simps, 
          unfold 
            cf_adj_LR_iso_components 
            op_ntcf_components 
            cf_adj_RL_iso_components
            Let_def
            Φ.cf_adjunction_unit_NTMap_op 
            Ψ.cf_adjunction_unit_NTMap_op
            assms(3-9)
            cat_op_simps
        )
        simp_all
  qed (auto simp: op_ntcf_def cf_adj_LR_iso_def nat_omega_simps)
qed

lemma op_ntcf_cf_adj_LR_iso[cat_op_simps]:
  assumes "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇" and "Ψ : 𝔉' CF 𝔊 :  ⇌⇌Cα 𝔇" 
  defines "op_𝔇  op_cat 𝔇"
    and "op_ℭ  op_cat "
    and "op_𝔉  op_cf 𝔉"
    and "op_𝔊  op_cf 𝔊"
    and "op_Φ  op_cf_adj Φ"
    and "op_𝔉'  op_cf 𝔉'"
    and "op_Ψ  op_cf_adj Ψ"
  shows
    "op_ntcf (cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' Ψ) =
      cf_adj_RL_iso op_𝔇 op_ℭ op_𝔊 op_𝔉 op_Φ op_𝔉' op_Ψ"
proof-
  interpret Φ: is_cf_adjunction α  𝔇 𝔉 𝔊 Φ by (rule assms(1))
  interpret Ψ: is_cf_adjunction α  𝔇 𝔉' 𝔊 Ψ by (rule assms(2))
  interpret ε: is_ntcf α 𝔇 𝔇 𝔉 CF 𝔊 ‹cf_id 𝔇 εC Φ
    by (rule Φ.cf_adjunction_counit_is_ntcf)
  have dom_lhs: "𝒟 (op_ntcf (cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' Ψ)) = 5"
    unfolding op_ntcf_def by (simp add: nat_omega_simps)
  show ?thesis
  proof(rule vsv_eqI, unfold dom_lhs)
    fix a assume prems: "a  5"
    then show
      "op_ntcf (cf_adj_LR_iso  𝔇 𝔊 𝔉 Φ 𝔉' Ψ)a =
        cf_adj_RL_iso op_𝔇 op_ℭ op_𝔊 op_𝔉 op_Φ op_𝔉' op_Ψa"
      by
        (
          elim_in_numeral, 
          use nothing in 
            fold nt_field_simps,
              unfold 
                cf_adj_LR_iso_components
                op_ntcf_components
                cf_adj_RL_iso_components
                Let_def
                Φ.op_ntcf_cf_adjunction_unit[symmetric]
                Ψ.op_ntcf_cf_adjunction_unit[symmetric]
                assms(3-9)
                cat_op_simps
        )
        simp_all
  qed (auto simp: op_ntcf_def cf_adj_RL_iso_def nat_omega_simps)
qed

lemma cf_adj_RL_iso_app_unique:
  fixes  𝔇 𝔉 𝔊 Φ 𝔊' Ψ
  assumes "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇" 
    and "Ψ : 𝔉 CF 𝔊' :  ⇌⇌Cα 𝔇" 
    and "x  𝔇Obj"
  defines "𝔊x  𝔊ObjMapx"
    and "𝔊'x  𝔊'ObjMapx"
    and "ε  εC Φ" 
    and "ε'  εC Ψ"
    and "f  cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' ΨNTMapx"
  shows
    "∃!f'.
      f' : 𝔊'x  𝔊x 
      ε'NTMapx = umap_fo 𝔉 x 𝔊x (εNTMapx) 𝔊'xArrValf'"
    "f : 𝔊'x iso 𝔊x"
    "ε'NTMapx = umap_fo 𝔉 x 𝔊x (εNTMapx) 𝔊'xArrValf"
proof-
  interpret Φ: is_cf_adjunction α  𝔇 𝔉 𝔊 Φ by (rule assms(1))
  interpret Ψ: is_cf_adjunction α  𝔇 𝔉 𝔊' Ψ by (rule assms(2))
  interpret ε: is_ntcf α 𝔇 𝔇 𝔉 CF 𝔊 ‹cf_id 𝔇 εC Φ
    by (rule Φ.cf_adjunction_counit_is_ntcf)
  show
    "∃!f'.
      f' : 𝔊'x  𝔊x 
      ε'NTMapx = umap_fo 𝔉 x 𝔊x (εNTMapx) 𝔊'xArrValf'"
    "f : 𝔊'x iso 𝔊x"
    "ε'NTMapx = umap_fo 𝔉 x 𝔊x (εNTMapx) 𝔊'xArrValf"
    by 
      (
        intro cf_adj_LR_iso_app_unique
          [
            OF Φ.is_cf_adjunction_op Ψ.is_cf_adjunction_op,
            unfolded cat_op_simps,
            OF assms(3),
            unfolded Ψ.cf_adjunction_unit_NTMap_op,
            folded Φ.op_ntcf_cf_adjunction_counit,
            folded op_ntcf_cf_adj_RL_iso[OF assms(1,2)],
            unfolded cat_op_simps,
            folded assms(4-8)
          ]
      )+
qed

lemma cf_adj_RL_iso_is_iso_functor:
  ―‹See Corollary 1 in Chapter IV-1 in \cite{mac_lane_categories_2010}.›
  assumes "Φ : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇" and "Ψ : 𝔉 CF 𝔊' :  ⇌⇌Cα 𝔇" 
  shows "∃!θ.
    θ : 𝔊' CF 𝔊 : 𝔇 ↦↦Cα  
    εC Ψ = εC Φ NTCF (𝔉 CF-NTCF θ)"
    and "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ : 𝔊' CF.iso 𝔊 : 𝔇 ↦↦Cα "
    and "εC Ψ =
      εC Φ NTCF (𝔉 CF-NTCF cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ)"
proof-
  interpret Φ: is_cf_adjunction α  𝔇 𝔉 𝔊 Φ by (rule assms(1))
  interpret Ψ: is_cf_adjunction α  𝔇 𝔉 𝔊' Ψ by (rule assms(2))
  interpret ε: is_ntcf α 𝔇 𝔇 𝔉 CF 𝔊 ‹cf_id 𝔇 εC Φ
    by (rule Φ.cf_adjunction_counit_is_ntcf)
  note cf_adj_LR_iso_is_iso_functor_op = cf_adj_LR_iso_is_iso_functor
    [
      OF Φ.is_cf_adjunction_op Ψ.is_cf_adjunction_op,
      folded 
        Φ.op_ntcf_cf_adjunction_counit 
        Ψ.op_ntcf_cf_adjunction_counit
        op_ntcf_cf_adj_RL_iso[OF assms]
    ]
  from cf_adj_LR_iso_is_iso_functor_op(1) obtain θ 
    where θ: "θ : op_cf 𝔊 CF op_cf 𝔊' : op_cat 𝔇 ↦↦Cα op_cat "
      and op_ntcf_ε_def: "op_ntcf (εC Ψ) =
        op_cf 𝔉 CF-NTCF θ NTCF op_ntcf (εC Φ)"
      and unique_θ': 
        "
          θ' : op_cf 𝔊 CF op_cf 𝔊' : op_cat 𝔇 ↦↦Cα op_cat ;
          op_ntcf (εC Ψ) = op_cf 𝔉 CF-NTCF θ' NTCF op_ntcf (εC Φ)
           θ' = θ"
      for θ'
    by metis
  interpret θ: is_ntcf α ‹op_cat 𝔇 ‹op_cat  ‹op_cf 𝔊 ‹op_cf 𝔊' θ 
    by (rule θ)
  show "∃!θ. θ : 𝔊' CF 𝔊 : 𝔇 ↦↦Cα   εC Ψ = εC Φ NTCF (𝔉 CF-NTCF θ)"
  proof(intro ex1I conjI; (elim conjE)?)
    show op_θ: "op_ntcf θ : 𝔊' CF 𝔊 : 𝔇 ↦↦Cα "
      by (rule θ.is_ntcf_op[unfolded cat_op_simps])
    from op_ntcf_ε_def have
      "op_ntcf (op_ntcf (εC Ψ)) =
        op_ntcf (op_cf 𝔉 CF-NTCF θ NTCF op_ntcf (εC Φ))"
      by simp
    then show ε_def: "εC Ψ = εC Φ NTCF (𝔉 CF-NTCF op_ntcf θ)"
      by 
        (
          cs_prems 
            cs_simp: cat_op_simps 
            cs_intro: adj_cs_intros cat_cs_intros cat_op_intros
        )
    fix θ' assume prems: 
      "θ' : 𝔊' CF 𝔊 : 𝔇 ↦↦Cα "
      "εC Ψ = εC Φ NTCF (𝔉 CF-NTCF θ')"
    interpret θ': is_ntcf α 𝔇  𝔊' 𝔊 θ' by (rule prems(1))   
    have "op_ntcf (εC Ψ) = op_cf 𝔉 CF-NTCF op_ntcf θ' NTCF op_ntcf (εC Φ)"
      by 
        (
          cs_concl 
            cs_simp: 
              prems(2) 
              op_ntcf_cf_ntcf_comp[symmetric] 
              op_ntcf_ntcf_vcomp[symmetric] 
            cs_intro: cat_cs_intros
        )
    from unique_θ'[OF θ'.is_ntcf_op this, symmetric] have
      "op_ntcf θ = op_ntcf (op_ntcf θ')"
      by simp
    then show "θ' = op_ntcf θ"  
      by (cs_prems cs_simp: cat_cs_simps cat_op_simps) simp
  qed
  from is_iso_ntcf.is_iso_ntcf_op[OF cf_adj_LR_iso_is_iso_functor_op(2)] show 
    "cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ : 𝔊' CF.iso 𝔊 : 𝔇 ↦↦Cα "
    by (cs_prems cs_simp: cat_op_simps cs_intro: adj_cs_intros cat_op_intros)
  from cf_adj_LR_iso_is_iso_functor_op(3) have 
    "op_ntcf (op_ntcf (εC Ψ)) =
      op_ntcf
        (
          op_cf 𝔉 CF-NTCF op_ntcf (cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ) NTCF 
          op_ntcf (εC Φ)
        )"
    by simp
  from 
    this 
    cf_adj_LR_iso_is_iso_functor_op(2)[ 
      unfolded op_ntcf_cf_adj_RL_iso[OF assms]
      ]
  show "εC Ψ = εC Φ NTCF (𝔉 CF-NTCF cf_adj_RL_iso  𝔇 𝔉 𝔊 Φ 𝔊' Ψ)"
    by 
      (
        cs_prems
          cs_simp: cat_op_simps cat_op_simps 
          cs_intro: ntcf_cs_intros adj_cs_intros cat_cs_intros cat_op_intros
      )
qed



subsection‹Further properties of the adjoint functors›

lemma (in is_cf_adjunction) cf_adj_exp_cf_cat:
  ―‹See Proposition 4.4.6 in \cite{riehl_category_2016}.›
  assumes "𝒵 β" and "α  β" and "category α 𝔍"
  shows
    "cf_adjunction_of_unit
      β
      (exp_cf_cat α 𝔉 𝔍)
      (exp_cf_cat α 𝔊 𝔍)
      (exp_ntcf_cat α (ηC Φ) 𝔍) :
      exp_cf_cat α 𝔉 𝔍 CF exp_cf_cat α 𝔊 𝔍 :
      cat_FUNCT α 𝔍  ⇌⇌Cβ cat_FUNCT α 𝔍 𝔇"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  interpret 𝔍: category α 𝔍 by (rule assms(3))
  show ?thesis
  proof
    (
      rule counit_unit_is_cf_adjunction(1)[
        where ε = ‹exp_ntcf_cat α (εC Φ) 𝔍
        ]
    )
    from assms show "exp_ntcf_cat α (ηC Φ) 𝔍 :
      cf_id (cat_FUNCT α 𝔍 ) CF exp_cf_cat α 𝔊 𝔍 CF exp_cf_cat α 𝔉 𝔍 :
      cat_FUNCT α 𝔍  ↦↦Cβ cat_FUNCT α 𝔍 "
      by 
        (
          cs_concl
            cs_simp:
              cat_cs_simps cat_FUNCT_cs_simps 
              exp_cf_cat_cf_id_cat[symmetric] exp_cf_cat_cf_comp[symmetric] 
            cs_intro:
              cat_cs_intros cat_small_cs_intros cat_FUNCT_cs_intros adj_cs_intros
        )
    from assms show 
      "exp_ntcf_cat α (εC Φ) 𝔍 :
        exp_cf_cat α 𝔉 𝔍 CF exp_cf_cat α 𝔊 𝔍 CF cf_id (cat_FUNCT α 𝔍 𝔇) :
        cat_FUNCT α 𝔍 𝔇 ↦↦Cβ cat_FUNCT α 𝔍 𝔇"
      by
        (
          cs_concl
            cs_simp:
              cat_cs_simps 
              cat_FUNCT_cs_simps 
              exp_cf_cat_cf_id_cat[symmetric] 
              exp_cf_cat_cf_comp[symmetric] 
            cs_intro:
              cat_cs_intros cat_small_cs_intros cat_FUNCT_cs_intros adj_cs_intros
        )
    note [symmetric, cat_cs_simps] =
      ntcf_id_exp_cf_cat 
      exp_ntcf_cat_ntcf_vcomp 
      exp_ntcf_cat_ntcf_cf_comp
      exp_ntcf_cat_cf_ntcf_comp
    from assms show
      "(exp_cf_cat α 𝔊 𝔍 CF-NTCF exp_ntcf_cat α (εC Φ) 𝔍) NTCF
        (exp_ntcf_cat α (ηC Φ) 𝔍 NTCF-CF exp_cf_cat α 𝔊 𝔍) =
        ntcf_id (exp_cf_cat α 𝔊 𝔍)"
      by 
        (
          cs_concl 
            cs_simp: adj_cs_simps cat_cs_simps  
            cs_intro: adj_cs_intros cat_cs_intros
        )
    from assms show
      "exp_ntcf_cat α (εC Φ) 𝔍 NTCF-CF exp_cf_cat α 𝔉 𝔍 NTCF
      (exp_cf_cat α 𝔉 𝔍 CF-NTCF exp_ntcf_cat α (ηC Φ) 𝔍) =
      ntcf_id (exp_cf_cat α 𝔉 𝔍)"
      by 
        (
          cs_concl 
            cs_simp: adj_cs_simps cat_cs_simps  
            cs_intro: adj_cs_intros cat_cs_intros
        )
  qed
    (
      use assms in 
        cs_concl
            cs_intro: cat_cs_intros cat_small_cs_intros cat_FUNCT_cs_intros
    )+
qed

lemma (in is_cf_adjunction) cf_adj_exp_cf_cat_exp_cf_cat:
  ―‹See Proposition 4.4.6 in \cite{riehl_category_2016}.›
  assumes "𝒵 β" and "α  β" and "category α 𝔄"
  shows
    "cf_adjunction_of_unit
      β
      (exp_cat_cf α 𝔄 𝔊)
      (exp_cat_cf α 𝔄 𝔉)
      (exp_cat_ntcf α 𝔄 (ηC Φ)) :
      exp_cat_cf α 𝔄 𝔊 CF exp_cat_cf α 𝔄 𝔉 :
      cat_FUNCT α  𝔄 ⇌⇌Cβ cat_FUNCT α 𝔇 𝔄"
proof-

  interpret β: 𝒵 β by (rule assms(1))
  interpret 𝔄: category α 𝔄 by (rule assms(3))

  show ?thesis
  proof
    (
      rule counit_unit_is_cf_adjunction(1)[
        where ε = ‹exp_cat_ntcf α 𝔄 (εC Φ)
        ]
    )
    from assms is_cf_adjunction_axioms show
      "exp_cat_ntcf α 𝔄 (ηC Φ) :
        cf_id (cat_FUNCT α  𝔄) CF exp_cat_cf α 𝔄 𝔉 CF exp_cat_cf α 𝔄 𝔊 :
        cat_FUNCT α  𝔄 ↦↦Cβ cat_FUNCT α  𝔄"
      by 
        (
          cs_concl
            cs_simp:
              exp_cat_cf_cat_cf_id[symmetric] exp_cat_cf_cf_comp[symmetric] 
            cs_intro: cat_small_cs_intros cat_FUNCT_cs_intros adj_cs_intros
        )
    from assms is_cf_adjunction_axioms show 
      "exp_cat_ntcf α 𝔄 (εC Φ) :
        exp_cat_cf α 𝔄 𝔊 CF exp_cat_cf α 𝔄 𝔉 CF cf_id (cat_FUNCT α 𝔇 𝔄) :
        cat_FUNCT α 𝔇 𝔄 ↦↦Cβ cat_FUNCT α 𝔇 𝔄"
      by
        (
          cs_concl
            cs_simp: 
              exp_cat_cf_cat_cf_id[symmetric] exp_cat_cf_cf_comp[symmetric] 
            cs_intro: cat_small_cs_intros cat_FUNCT_cs_intros adj_cs_intros
        )
    note [symmetric, cat_cs_simps] =
      ntcf_id_exp_cat_cf
      exp_cat_ntcf_ntcf_vcomp
      exp_cat_ntcf_ntcf_cf_comp
      exp_cat_ntcf_cf_ntcf_comp
    from assms show
      "exp_cat_cf α 𝔄 𝔉 CF-NTCF exp_cat_ntcf α 𝔄 (εC Φ) NTCF
        (exp_cat_ntcf α 𝔄 (ηC Φ) NTCF-CF exp_cat_cf α 𝔄 𝔉) =
        ntcf_id (exp_cat_cf α 𝔄 𝔉)"
      by
        (
          cs_concl 
            cs_simp: adj_cs_simps cat_cs_simps
            cs_intro: adj_cs_intros cat_cs_intros
        )
    from assms show
      "exp_cat_ntcf α 𝔄 (εC Φ) NTCF-CF exp_cat_cf α 𝔄 𝔊 NTCF
        (exp_cat_cf α 𝔄 𝔊 CF-NTCF exp_cat_ntcf α 𝔄 (ηC Φ)) =
        ntcf_id (exp_cat_cf α 𝔄 𝔊)"
      by 
        (
          cs_concl 
            cs_simp: adj_cs_simps cat_cs_simps
            cs_intro: adj_cs_intros cat_cs_intros
        )
  qed
    (
      use assms in 
        cs_concl
            cs_intro: cat_cs_intros cat_small_cs_intros cat_FUNCT_cs_intros
    )+

qed

text‹\newpage›

end

Theory CZH_UCAT_Kan

(* Copyright 2021 (C) Mihails Milehins *)

section‹Simple Kan extensions›
theory CZH_UCAT_Kan
  imports 
    CZH_Elementary_Categories.CZH_ECAT_Comma
    CZH_UCAT_Limit
    CZH_UCAT_Adjoints
begin



subsection‹Background›

named_theorems ua_field_simps

definition UObj :: V where [ua_field_simps]: "UObj = 0"
definition UArr :: V where [ua_field_simps]: "UArr = 1"

named_theorems cat_Kan_cs_simps
named_theorems cat_Kan_cs_intros



subsection‹Kan extension›


subsubsection‹Definition and elementary properties›


text‹See Chapter X-3 in \cite{mac_lane_categories_2010}.›

locale is_cat_rKe = 
  AG: is_functor α 𝔅  𝔎 + 
  Ran: is_functor α  𝔄 𝔊 +
  ntcf_rKe: is_ntcf α 𝔅 𝔄 𝔊 CF 𝔎 𝔗 ε
  for α 𝔅  𝔄 𝔎 𝔗 𝔊 ε +
  assumes cat_rKe_ua_fo:
    "universal_arrow_fo
      (exp_cat_cf α 𝔄 𝔎)
      (cf_map 𝔗)
      (cf_map 𝔊)
      (ntcf_arrow ε)"

syntax "_is_cat_rKe" :: "V  V  V  V  V  V  V  V  bool"
  ((_ :/ _ CF _ CF.rKeı _ :/ _ C _ C _) [51, 51, 51, 51, 51, 51, 51] 51)
translations "ε : 𝔊 CF 𝔎 CF.rKeα 𝔗 : 𝔅 C  C 𝔄"  
  "CONST is_cat_rKe α 𝔅  𝔄 𝔎 𝔗 𝔊 ε"

locale is_cat_lKe =
  AG: is_functor α 𝔅  𝔎 +
  Lan: is_functor α  𝔄 𝔉 +
  ntcf_lKe: is_ntcf α 𝔅 𝔄 𝔗 𝔉 CF 𝔎 η
  for α 𝔅  𝔄 𝔎 𝔗 𝔉 η +
  assumes cat_lKe_ua_fo:
    "universal_arrow_fo
      (exp_cat_cf α (op_cat 𝔄) (op_cf 𝔎))
      (cf_map 𝔗)
      (cf_map 𝔉)
      (ntcf_arrow (op_ntcf η))"

syntax "_is_cat_lKe" :: "V  V  V  V  V  V  V  V  bool"
  ((_ :/ _ CF.lKeı _ CF _ :/ _ C _ C _) [51, 51, 51, 51, 51, 51, 51] 51)
translations "η : 𝔗 CF.lKeα 𝔉 CF 𝔎 : 𝔅 C  C 𝔄"  
  "CONST is_cat_lKe α 𝔅  𝔄 𝔎 𝔗 𝔉 η"


text‹Rules.›

lemma (in is_cat_rKe) is_cat_rKe_axioms'[cat_Kan_cs_intros]:
  assumes "α' = α"
    and "𝔊' = 𝔊"
    and "𝔎' = 𝔎"
    and "𝔗' = 𝔗"
    and "𝔅' = 𝔅"
    and "𝔄' = 𝔄"
    and "ℭ' = "
  shows "ε : 𝔊' CF 𝔎' CF.rKeα' 𝔗' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_rKe_axioms)

mk_ide rf is_cat_rKe_def[unfolded is_cat_rKe_axioms_def]
  |intro is_cat_rKeI|
  |dest is_cat_rKeD[dest]|
  |elim is_cat_rKeE[elim]|

lemmas [cat_Kan_cs_intros] = is_cat_rKeD(1-3)

lemma (in is_cat_lKe) is_cat_lKe_axioms'[cat_Kan_cs_intros]:
  assumes "α' = α"
    and "𝔉' = 𝔉"
    and "𝔎' = 𝔎"
    and "𝔗' = 𝔗"
    and "𝔅' = 𝔅"
    and "𝔄' = 𝔄"
    and "ℭ' = "
  shows "η : 𝔗' CF.lKeα 𝔉' CF 𝔎' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_lKe_axioms)

mk_ide rf is_cat_lKe_def[unfolded is_cat_lKe_axioms_def]
  |intro is_cat_lKeI|
  |dest is_cat_lKeD[dest]|
  |elim is_cat_lKeE[elim]|

lemmas [cat_Kan_cs_intros] = is_cat_lKeD(1-3)


text‹Duality.›

lemma (in is_cat_rKe) is_cat_lKe_op:
  "op_ntcf ε :
    op_cf 𝔗 CF.lKeα op_cf 𝔊 CF op_cf 𝔎 :
    op_cat 𝔅 C op_cat  C op_cat 𝔄"
  by (intro is_cat_lKeI, unfold cat_op_simps; (intro cat_rKe_ua_fo)?)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)+

lemma (in is_cat_rKe) is_cat_lKe_op'[cat_op_intros]:
  assumes "𝔗' = op_cf 𝔗"
    and "𝔊' = op_cf 𝔊"
    and "𝔎' = op_cf 𝔎"
    and "𝔅' = op_cat 𝔅"
    and "𝔄' = op_cat 𝔄"
    and "ℭ' = op_cat "
  shows "op_ntcf ε : 𝔗' CF.lKeα 𝔊' CF 𝔎' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_lKe_op)

lemmas [cat_op_intros] = is_cat_rKe.is_cat_lKe_op'

lemma (in is_cat_lKe) is_cat_rKe_op:
  "op_ntcf η :
    op_cf 𝔉 CF op_cf 𝔎 CF.rKeα op_cf 𝔗 :
    op_cat 𝔅 C op_cat  C op_cat 𝔄"
  by (intro is_cat_rKeI, unfold cat_op_simps; (intro cat_lKe_ua_fo)?)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)+

lemma (in is_cat_lKe) is_cat_lKe_op'[cat_op_intros]:
  assumes "𝔗' = op_cf 𝔗"
    and "𝔉' = op_cf 𝔉"
    and "𝔎' = op_cf 𝔎"
    and "𝔅' = op_cat 𝔅"
    and "𝔄' = op_cat 𝔄"
    and "ℭ' = op_cat "
  shows "op_ntcf η : 𝔉' CF 𝔎' CF.rKeα 𝔗' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_rKe_op)

lemmas [cat_op_intros] = is_cat_lKe.is_cat_lKe_op'


text‹Elementary properties.›

lemma (in is_cat_rKe) cat_rKe_exp_cat_cf_cat_FUNCT_is_arr:
  assumes "𝒵 β" and "α  β"
  shows "exp_cat_cf α 𝔄 𝔎 : cat_FUNCT α  𝔄 ↦↦C.tinyβ cat_FUNCT α 𝔅 𝔄"
  by 
    ( 
      rule exp_cat_cf_is_tiny_functor[
        OF assms Ran.HomCod.category_axioms AG.is_functor_axioms
        ]
    )

lemma (in is_cat_lKe) cat_lKe_exp_cat_cf_cat_FUNCT_is_arr:
  assumes "𝒵 β" and "α  β"
  shows "exp_cat_cf α 𝔄 𝔎 : cat_FUNCT α  𝔄 ↦↦C.tinyβ cat_FUNCT α 𝔅 𝔄"
  by 
    ( 
      rule exp_cat_cf_is_tiny_functor[
        OF assms Lan.HomCod.category_axioms AG.is_functor_axioms
        ]
    )


subsubsection‹Universal property›


text‹
See Chapter X-3 in \cite{mac_lane_categories_2010} and 
\cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Kan_extension}
}.
›

lemma is_cat_rKeI':
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔊 :  ↦↦Cα 𝔄"
    and "ε : 𝔊 CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "𝔊' ε'.
       𝔊' :  ↦↦Cα 𝔄; ε' : 𝔊' CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄  
        ∃!σ. σ : 𝔊' CF 𝔊 :  ↦↦Cα 𝔄  ε' = ε NTCF (σ NTCF-CF 𝔎)" 
  shows "ε : 𝔊 CF 𝔎 CF.rKeα 𝔗 : 𝔅 C  C 𝔄"
proof-
  interpret 𝔎: is_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔊: is_functor α  𝔄 𝔊 by (rule assms(2))
  interpret ε: is_ntcf α 𝔅 𝔄 𝔊 CF 𝔎 𝔗 ε by (rule assms(3))
  let ?𝔄𝔎 = ‹exp_cat_cf α 𝔄 𝔎
    and ?𝔗 = ‹cf_map 𝔗
    and ?𝔊 = ‹cf_map 𝔊
  show ?thesis
  proof(intro is_cat_rKeI is_functor.universal_arrow_foI assms)
    define β where "β = α + ω"
    have "𝒵 β" and αβ: "α  β" 
      by (simp_all add: β_def 𝔎.𝒵_Limit_αω 𝔎.𝒵_ω_αω 𝒵_def 𝔎.𝒵_α_αω)
    then interpret β: 𝒵 β by simp 
    show "?𝔄𝔎 : cat_FUNCT α  𝔄 ↦↦Cβ cat_FUNCT α 𝔅 𝔄"
      by 
        ( 
          cs_concl cs_intro: 
            cat_small_cs_intros 
            exp_cat_cf_is_tiny_functor[
              OF β.𝒵_axioms αβ 𝔊.HomCod.category_axioms assms(1)
              ]
        )
    from αβ assms(2) show "cf_map 𝔊  cat_FUNCT α  𝔄Obj"
      unfolding cat_FUNCT_components
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_FUNCT_cs_intros)
    from assms(1-3) show "ntcf_arrow ε :
      ?𝔄𝔎ObjMap?𝔊 cat_FUNCT α 𝔅 𝔄 ?𝔗"
      by 
        (
          cs_concl 
            cs_simp: cat_Kan_cs_simps cat_FUNCT_cs_simps cat_FUNCT_components(1) 
            cs_intro: cat_FUNCT_cs_intros
        )
    fix 𝔉' ε' assume prems: 
      "𝔉'  cat_FUNCT α  𝔄Obj"
      "ε' : ?𝔄𝔎ObjMap𝔉' cat_FUNCT α 𝔅 𝔄 ?𝔗"
    from prems(1) have "𝔉'  cf_maps α  𝔄"  
      unfolding cat_FUNCT_components(1) by simp
    then obtain 𝔉 where 𝔉'_def: "𝔉' = cf_map 𝔉" and 𝔉: "𝔉 :  ↦↦Cα 𝔄" 
      by clarsimp
    note ε' = cat_FUNCT_is_arrD[OF prems(2)]
    from ε'(1) 𝔉 have ε'_is_ntcf: 
      "ntcf_of_ntcf_arrow 𝔅 𝔄 ε' : 𝔉 CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄"
      by 
        ( 
          cs_prems 
            cs_simp: 𝔉'_def cat_Kan_cs_simps cat_FUNCT_cs_simps 
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros
        )
    from assms(4)[OF 𝔉 ε'_is_ntcf] obtain σ
      where σ: "σ : 𝔉 CF 𝔊 :  ↦↦Cα 𝔄" 
        and ε'_def': "ntcf_of_ntcf_arrow 𝔅 𝔄 ε' = ε NTCF (σ NTCF-CF 𝔎)"
        and unique_σ: "σ'. 
           
            σ' : 𝔉 CF 𝔊 :  ↦↦Cα 𝔄;
            ntcf_of_ntcf_arrow 𝔅 𝔄 ε' = ε NTCF (σ' NTCF-CF 𝔎) 
            σ' = σ"
      by metis
    show "∃!f'.
      f' : 𝔉' cat_FUNCT α  𝔄 ?𝔊 
      ε' = umap_fo ?𝔄𝔎 ?𝔗 ?𝔊 (ntcf_arrow ε) 𝔉'ArrValf'"
    proof(intro ex1I conjI; (elim conjE)?, unfold 𝔉'_def)
      from σ show "ntcf_arrow σ : cf_map 𝔉 cat_FUNCT α  𝔄 ?𝔊"
        by (cs_concl cs_intro: cat_FUNCT_cs_intros)
      from αβ assms(1-3) σ ε'(1) show 
        "ε' = umap_fo
          ?𝔄𝔎 ?𝔗 ?𝔊 (ntcf_arrow ε) (cf_map 𝔉)ArrValntcf_arrow σ"
        by (subst ε')
          (
            cs_concl 
              cs_simp: 
                ε'_def'[symmetric] cat_cs_simps cat_FUNCT_cs_simps cat_Kan_cs_simps 
              cs_intro: 
                cat_small_cs_intros 
                cat_cs_intros 
                cat_Kan_cs_intros
                cat_FUNCT_cs_intros
          )
      fix σ' assume prems:
        "σ' : cf_map 𝔉 cat_FUNCT α  𝔄 ?𝔊"
        "ε' = umap_fo ?𝔄𝔎 ?𝔗 ?𝔊 (ntcf_arrow ε) (cf_map 𝔉)ArrValσ'"
      note σ' = cat_FUNCT_is_arrD[OF prems(1)]
      from σ'(1) 𝔉 have "ntcf_of_ntcf_arrow  𝔄 σ' : 𝔉 CF 𝔊 :  ↦↦Cα 𝔄"
        by (cs_prems cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
      moreover from prems(2) prems(1) αβ assms(1-3) this ε'(1) have 
        "ntcf_of_ntcf_arrow 𝔅 𝔄 ε' =
          ε NTCF (ntcf_of_ntcf_arrow  𝔄 σ' NTCF-CF 𝔎)"
        by (subst (asm) ε'(2))
          (
            cs_prems 
              cs_simp: cat_Kan_cs_simps cat_FUNCT_cs_simps cat_cs_simps 
              cs_intro: 
                cat_Kan_cs_intros
                cat_small_cs_intros
                cat_cs_intros
                cat_FUNCT_cs_intros
          )
      ultimately have σ_def: "σ = ntcf_of_ntcf_arrow  𝔄 σ'" 
        by (rule unique_σ[symmetric])
      show "σ' = ntcf_arrow σ"
        by (subst σ'(2), use nothing in subst σ_def›)
          (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    qed
  qed
qed

lemma is_cat_lKeI':
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔉 :  ↦↦Cα 𝔄"
    and "η : 𝔗 CF 𝔉 CF 𝔎 : 𝔅 ↦↦Cα 𝔄"
    and "𝔉' η'.
       𝔉' :  ↦↦Cα 𝔄; η' : 𝔗 CF 𝔉' CF 𝔎 : 𝔅 ↦↦Cα 𝔄  
        ∃!σ. σ : 𝔉 CF 𝔉' :  ↦↦Cα 𝔄  η' = (σ NTCF-CF 𝔎) NTCF η" 
  shows "η : 𝔗 CF.lKeα 𝔉 CF 𝔎 : 𝔅 C  C 𝔄"
proof-
  interpret 𝔎: is_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔉: is_functor α  𝔄 𝔉 by (rule assms(2))
  interpret η: is_ntcf α 𝔅 𝔄 𝔗 𝔉 CF 𝔎 η by (rule assms(3))
  have 
    "∃!σ.
      σ : 𝔊' CF op_cf 𝔉 : op_cat  ↦↦Cα op_cat 𝔄 
      η' = op_ntcf η NTCF (σ NTCF-CF op_cf 𝔎)"
    if "𝔊' : op_cat  ↦↦Cα op_cat 𝔄"
      and "η' : 𝔊' CF op_cf 𝔎 CF op_cf 𝔗 : op_cat 𝔅 ↦↦Cα op_cat 𝔄"
    for 𝔊' η'
  proof-
    interpret 𝔊': is_functor α ‹op_cat  ‹op_cat 𝔄 𝔊' by (rule that(1))
    interpret η': 
      is_ntcf α ‹op_cat 𝔅 ‹op_cat 𝔄 𝔊' CF op_cf 𝔎 ‹op_cf 𝔗 η'
      by (rule that(2))
    from assms(4)[
        OF is_functor.is_functor_op[OF that(1), unfolded cat_op_simps],
        OF is_ntcf.is_ntcf_op[OF that(2), unfolded cat_op_simps]
        ]
    obtain σ where σ: "σ : 𝔉 CF op_cf 𝔊' :  ↦↦Cα 𝔄" 
      and op_η'_def: "op_ntcf η' = σ NTCF-CF 𝔎 NTCF η"
      and unique_σ':
        "
          σ' : 𝔉 CF op_cf 𝔊' :  ↦↦Cα 𝔄;
          op_ntcf η' = σ' NTCF-CF 𝔎 NTCF η
           σ' = σ"
      for σ'
      by metis
    interpret σ: is_ntcf α  𝔄 𝔉 ‹op_cf 𝔊' σ by (rule σ)
    show ?thesis
    proof(intro ex1I conjI; (elim conjE)?)
      show "op_ntcf σ : 𝔊' CF op_cf 𝔉 : op_cat  ↦↦Cα op_cat 𝔄"
        by (rule σ.is_ntcf_op[unfolded cat_op_simps])
      from op_η'_def have "op_ntcf (op_ntcf η') = op_ntcf (σ NTCF-CF 𝔎 NTCF η)"
        by simp
      from this σ assms(1-3) show η'_def:
        "η' = op_ntcf η NTCF (op_ntcf σ NTCF-CF op_cf 𝔎)"
        by (cs_prems cs_simp: cat_op_simps cs_intro: cat_cs_intros)
      fix σ' assume prems:
        "σ' : 𝔊' CF op_cf 𝔉 : op_cat  ↦↦Cα op_cat 𝔄"
        "η' = op_ntcf η NTCF (σ' NTCF-CF op_cf 𝔎)"
      interpret σ': is_ntcf α ‹op_cat  ‹op_cat 𝔄 𝔊' ‹op_cf 𝔉 σ' 
        by (rule prems(1))
      from prems(2) have 
        "op_ntcf η' = op_ntcf (op_ntcf η NTCF (σ' NTCF-CF op_cf 𝔎))"
        by simp
      also have " = op_ntcf σ' NTCF-CF 𝔎 NTCF η"   
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros
          )
      finally have "op_ntcf η' = op_ntcf σ' NTCF-CF 𝔎 NTCF η" by simp
      from unique_σ'[OF σ'.is_ntcf_op[unfolded cat_op_simps] this] show 
        "σ' = op_ntcf σ" 
        by (auto simp: cat_op_simps)
    qed
  qed
  from 
    is_cat_rKeI'
      [
        OF 𝔎.is_functor_op 𝔉.is_functor_op η.is_ntcf_op[unfolded cat_op_simps], 
        unfolded cat_op_simps, 
        OF this
      ]
  interpret η: is_cat_rKe 
    α 
    ‹op_cat 𝔅 
    ‹op_cat 
    ‹op_cat 𝔄 
    ‹op_cf 𝔎 
    ‹op_cf 𝔗 
    ‹op_cf 𝔉 
    ‹op_ntcf η
    by simp
  show "η : 𝔗 CF.lKeα 𝔉 CF 𝔎 : 𝔅 C  C 𝔄"
    by (rule η.is_cat_lKe_op[unfolded cat_op_simps])
qed

lemma (in is_cat_rKe) cat_rKe_unique:
  assumes "𝔊' :  ↦↦Cα 𝔄" and "ε' : 𝔊' CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄"
  shows "∃!σ. σ : 𝔊' CF 𝔊 :  ↦↦Cα 𝔄  ε' = ε NTCF (σ NTCF-CF 𝔎)" 
proof-

  interpret 𝔊': is_functor α  𝔄 𝔊' by (rule assms(1))
  interpret ε': is_ntcf α 𝔅 𝔄 𝔊' CF 𝔎 𝔗 ε' by (rule assms(2))

  let ?𝔗 = ‹cf_map 𝔗
    and ?𝔊 = ‹cf_map 𝔊
    and ?𝔊' = ‹cf_map 𝔊'
    and  = ‹ntcf_arrow ε
    and ?ε' = ‹ntcf_arrow ε'

  define β where "β = α + ω"
  have "𝒵 β" and αβ: "α  β"
    by (simp_all add: β_def AG.𝒵_Limit_αω AG.𝒵_ω_αω 𝒵_def AG.𝒵_α_αω)
  then interpret β: 𝒵 β by simp
  
  interpret 𝔄𝔎: is_tiny_functor 
    β ‹cat_FUNCT α  𝔄 ‹cat_FUNCT α 𝔅 𝔄 ‹exp_cat_cf α 𝔄 𝔎
    by (rule cat_rKe_exp_cat_cf_cat_FUNCT_is_arr[OF β.𝒵_axioms αβ])

  from assms(1) have 𝔊': "?𝔊'  cat_FUNCT α  𝔄Obj"
    by (cs_concl cs_simp: cat_FUNCT_components(1) cs_intro: cat_FUNCT_cs_intros)
  with assms(2) have
    "?ε' : exp_cat_cf α 𝔄 𝔎ObjMap?𝔊' cat_FUNCT α 𝔅 𝔄 ?𝔗"
    by 
      ( 
        cs_concl 
          cs_simp: cat_Kan_cs_simps cat_FUNCT_cs_simps 
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros
      )

  from
    is_functor.universal_arrow_foD(3)[
      OF 𝔄𝔎.is_functor_axioms cat_rKe_ua_fo 𝔊' this
      ]
  obtain f' where f': "f' : cf_map 𝔊' cat_FUNCT α  𝔄 cf_map 𝔊"
    and ε'_def: "?ε' = umap_fo (exp_cat_cf α 𝔄 𝔎) ?𝔗 ?𝔊  ?𝔊'ArrValf'"
    and f'_unique: 
      " 
        f'' : ?𝔊' cat_FUNCT α  𝔄 ?𝔊;
        ntcf_arrow ε' = umap_fo (exp_cat_cf α 𝔄 𝔎) ?𝔗 ?𝔊  ?𝔊'ArrValf'' 
         f'' = f'"
    for f''
    by metis
  
  show ?thesis
  proof(intro ex1I conjI; (elim conjE)?)
    from ε'_def cat_FUNCT_is_arrD(1)[OF f'] show
      "ε' = ε NTCF (ntcf_of_ntcf_arrow  𝔄 f' NTCF-CF 𝔎)"
      by (subst (asm) cat_FUNCT_is_arrD(2)[OF f']) (*slow*)
        (
          cs_prems 
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps cat_Kan_cs_simps 
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros
        )
    from cat_FUNCT_is_arrD(1)[OF f'] show f'_is_arr:
      "ntcf_of_ntcf_arrow  𝔄 f' : 𝔊' CF 𝔊 :  ↦↦Cα 𝔄"
      by (cs_prems cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
    fix σ assume prems: 
      "σ : 𝔊' CF 𝔊 :  ↦↦Cα 𝔄" "ε' = ε NTCF (σ NTCF-CF 𝔎)"
    interpret σ: is_ntcf α  𝔄 𝔊' 𝔊 σ by (rule prems(1))
    from prems(1) have σ: 
      "ntcf_arrow σ : cf_map 𝔊' cat_FUNCT α  𝔄 cf_map 𝔊"
      by (cs_concl cs_intro: cat_FUNCT_cs_intros)
    from prems have ε'_def: "ntcf_arrow ε' =
      umap_fo (exp_cat_cf α 𝔄 𝔎) ?𝔗 ?𝔊  ?𝔊'ArrValntcf_arrow σ"
      by 
        (
          cs_concl
            cs_simp: prems(2) cat_Kan_cs_simps cat_cs_simps cat_FUNCT_cs_simps 
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros
        )
    show "σ = ntcf_of_ntcf_arrow  𝔄 f'"
      unfolding f'_unique[OF σ ε'_def, symmetric]
      by (cs_concl cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
  qed

qed

lemma (in is_cat_lKe) cat_lKe_unique:
  assumes "𝔉' :  ↦↦Cα 𝔄" and "η' : 𝔗 CF 𝔉' CF 𝔎 : 𝔅 ↦↦Cα 𝔄"
  shows "∃!σ. σ : 𝔉 CF 𝔉' :  ↦↦Cα 𝔄  η' = (σ NTCF-CF 𝔎) NTCF η" 
proof-

  interpret 𝔉': is_functor α  𝔄 𝔉' by (rule assms(1))
  interpret η': is_ntcf α 𝔅 𝔄 𝔗 𝔉' CF 𝔎 η' by (rule assms(2))
  interpret η: is_cat_rKe 
    α ‹op_cat 𝔅 ‹op_cat  ‹op_cat 𝔄 ‹op_cf 𝔎 ‹op_cf 𝔗 ‹op_cf 𝔉 ‹op_ntcf η
    by (rule is_cat_rKe_op)

  from η.cat_rKe_unique[OF 𝔉'.is_functor_op η'.is_ntcf_op[unfolded cat_op_simps]]
  obtain σ where σ: "σ : op_cf 𝔉' CF op_cf 𝔉 : op_cat  ↦↦Cα op_cat 𝔄"
    and η'_def: "op_ntcf η' = op_ntcf η NTCF (σ NTCF-CF op_cf 𝔎)"
    and unique_σ': "σ'.
      
        σ' : op_cf 𝔉' CF op_cf 𝔉 : op_cat  ↦↦Cα op_cat 𝔄;
        op_ntcf η' = op_ntcf η NTCF (σ' NTCF-CF op_cf 𝔎) 
        σ' = σ"
    by metis

  interpret σ: is_ntcf α ‹op_cat  ‹op_cat 𝔄 ‹op_cf 𝔉' ‹op_cf 𝔉 σ 
    by (rule σ)
  
  show ?thesis
  proof(intro ex1I conjI; (elim conjE)?)
    show "op_ntcf σ : 𝔉 CF 𝔉' :  ↦↦Cα 𝔄"
      by (rule σ.is_ntcf_op[unfolded cat_op_simps])
    have "η' = op_ntcf (op_ntcf η')" by (cs_concl cs_simp: cat_op_simps)
    also from η'_def have " = op_ntcf (op_ntcf η NTCF (σ NTCF-CF op_cf 𝔎))"
      by simp
    also have " = op_ntcf σ NTCF-CF 𝔎 NTCF η"
      by (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros)
    finally show "η' = op_ntcf σ NTCF-CF 𝔎 NTCF η" by simp
    fix σ' assume prems: 
      "σ' : 𝔉 CF 𝔉' :  ↦↦Cα 𝔄"
      "η' = σ' NTCF-CF 𝔎 NTCF η"
    interpret σ': is_ntcf α  𝔄 𝔉 𝔉' σ' by (rule prems(1))
    from prems(2) have "op_ntcf η' = op_ntcf (σ' NTCF-CF 𝔎 NTCF η)"
      by simp
    also have " = op_ntcf η NTCF (op_ntcf σ' NTCF-CF op_cf 𝔎)"
      by (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros)
    finally have "op_ntcf η' = op_ntcf η NTCF (op_ntcf σ' NTCF-CF op_cf 𝔎)"
      by simp
    from unique_σ'[OF σ'.is_ntcf_op this] show "σ' = op_ntcf σ"
      by (auto simp: cat_op_simps)
  qed

qed


subsubsection‹Further properties›

lemma (in is_cat_rKe) cat_rKe_ntcf_ua_fo_is_iso_ntcf_if_ge_Limit:
  assumes "𝒵 β" and "α  β"
  shows 
    "ntcf_ua_fo β (exp_cat_cf α 𝔄 𝔎) (cf_map 𝔗) (cf_map 𝔊) (ntcf_arrow ε) :
      HomO.Cβcat_FUNCT α  𝔄(-,cf_map 𝔊) CF.iso
      HomO.Cβcat_FUNCT α 𝔅 𝔄(-,cf_map 𝔗) CF op_cf (exp_cat_cf α 𝔄 𝔎) :
      op_cat (cat_FUNCT α  𝔄) ↦↦Cβ cat_Set β"
proof-
  interpret 𝔄_𝔎: 
    is_tiny_functor β ‹cat_FUNCT α  𝔄 ‹cat_FUNCT α 𝔅 𝔄 ‹exp_cat_cf α 𝔄 𝔎
    by 
      (
        rule exp_cat_cf_is_tiny_functor[
          OF assms Ran.HomCod.category_axioms AG.is_functor_axioms
          ]
      )
  show ?thesis
    by 
      (
        rule is_functor.cf_ntcf_ua_fo_is_iso_ntcf[
          OF 𝔄_𝔎.is_functor_axioms cat_rKe_ua_fo
          ]
      )
qed

lemma (in is_cat_lKe) cat_lKe_ntcf_ua_fo_is_iso_ntcf_if_ge_Limit:
  assumes "𝒵 β" and "α  β"
  defines "𝔄𝔎  exp_cat_cf α (op_cat 𝔄) (op_cf 𝔎)"
    and "𝔄ℭ  cat_FUNCT α (op_cat ) (op_cat 𝔄)"
    and "𝔄𝔅  cat_FUNCT α (op_cat 𝔅) (op_cat 𝔄)"
  shows 
    "ntcf_ua_fo β 𝔄𝔎 (cf_map 𝔗) (cf_map 𝔉) (ntcf_arrow (op_ntcf η)) :
      HomO.Cβ𝔄ℭ(-,cf_map 𝔉) CF.iso HomO.Cβ𝔄𝔅(-,cf_map 𝔗) CF op_cf 𝔄𝔎 :
      op_cat 𝔄ℭ ↦↦Cβ cat_Set β"
proof-
  note simps = 𝔄ℭ_def 𝔄𝔅_def 𝔄𝔎_def
  interpret 𝔄_𝔎: is_tiny_functor β 𝔄ℭ 𝔄𝔅 𝔄𝔎
    unfolding simps
    by
      (
        rule exp_cat_cf_is_tiny_functor[
          OF assms(1,2) Lan.HomCod.category_op AG.is_functor_op
          ]
      )
  show ?thesis
    unfolding simps
    by 
      (
        rule is_functor.cf_ntcf_ua_fo_is_iso_ntcf[
          OF 𝔄_𝔎.is_functor_axioms[unfolded simps] cat_lKe_ua_fo
          ]
      )
qed



subsection‹The Kan extension›


text‹
The following subsection is based on the statement and proof of 
Theorem 1 in Chapter X-3 in \cite{mac_lane_categories_2010}.
In what follows, only the right Kan extension is considered for simplicity.
›


subsubsection‹Definition and elementary properties›

definition the_cf_rKe :: "V  V  V  (V  V)  V"
  where "the_cf_rKe α 𝔗 𝔎 lim_Obj =
    [
      (λc𝔎HomCodObj. lim_Obj cUObj),
      (
        λg𝔎HomCodArr. THE f.
          f :
            lim_Obj (𝔎HomCodDomg)UObj 𝔗HomCod
            lim_Obj (𝔎HomCodCodg)UObj 
          lim_Obj (𝔎HomCodDomg)UArr NTCF-CF g ACF 𝔎 =
            lim_Obj (𝔎HomCodCodg)UArr NTCF 
            ntcf_const ((𝔎HomCodCodg) CF 𝔎) (𝔗HomCod) f
      ),
      𝔎HomCod,
      𝔗HomCod
    ]"

definition the_ntcf_rKe :: "V  V  V  (V  V)  V"
  where "the_ntcf_rKe α 𝔗 𝔎 lim_Obj =
    [
      (
        λc𝔗HomDomObj.
          lim_Obj (𝔎ObjMapc)UArrNTMap0, c, 𝔎HomCodCId𝔎ObjMapc
      ),
      the_cf_rKe α 𝔗 𝔎 lim_Obj CF 𝔎,
      𝔗,
      𝔗HomDom,
      𝔗HomCod
    ]"


text‹Components.›

lemma the_cf_rKe_components:
  shows "the_cf_rKe α 𝔗 𝔎 lim_ObjObjMap = 
    (λc𝔎HomCodObj. lim_Obj cUObj)"
    and "the_cf_rKe α 𝔗 𝔎 lim_ObjArrMap =
    (
      λg𝔎HomCodArr. THE f.
        f :
          lim_Obj (𝔎HomCodDomg)UObj 𝔗HomCod
          lim_Obj (𝔎HomCodCodg)UObj 
        lim_Obj (𝔎HomCodDomg)UArr NTCF-CF g ACF 𝔎 =
          lim_Obj (𝔎HomCodCodg)UArr NTCF 
          ntcf_const ((𝔎HomCodCodg) CF 𝔎) (𝔗HomCod) f
    )"
    and "the_cf_rKe α 𝔗 𝔎 lim_ObjHomDom = 𝔎HomCod"
    and "the_cf_rKe α 𝔗 𝔎 lim_ObjHomCod = 𝔗HomCod"
  unfolding the_cf_rKe_def dghm_field_simps by (simp_all add: nat_omega_simps)

lemma the_ntcf_rKe_components:
  shows "the_ntcf_rKe α 𝔗 𝔎 lim_ObjNTMap =
      (
        λc𝔗HomDomObj.
          lim_Obj (𝔎ObjMapc)UArrNTMap0, c, 𝔎HomCodCId𝔎ObjMapc
      )"
    and "the_ntcf_rKe α 𝔗 𝔎 lim_ObjNTDom = the_cf_rKe α 𝔗 𝔎 lim_Obj CF 𝔎"
    and "the_ntcf_rKe α 𝔗 𝔎 lim_ObjNTCod = 𝔗"
    and "the_ntcf_rKe α 𝔗 𝔎 lim_ObjNTDGDom = 𝔗HomDom"
    and "the_ntcf_rKe α 𝔗 𝔎 lim_ObjNTDGCod = 𝔗HomCod"
  unfolding the_ntcf_rKe_def nt_field_simps by (simp_all add: nat_omega_simps)

context
  fixes α 𝔄 𝔅  𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)
interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

lemmas the_cf_rKe_components' = the_cf_rKe_components[
    where 𝔎=𝔎 and 𝔗=𝔗 and α=α, unfolded 𝔎.cf_HomCod 𝔗.cf_HomCod
    ]

lemmas [cat_Kan_cs_simps] = the_cf_rKe_components'(3,4)

lemmas the_ntcf_rKe_components' = the_ntcf_rKe_components[
    where 𝔎=𝔎 and 𝔗=𝔗 and α=α, unfolded 𝔎.cf_HomCod 𝔗.cf_HomCod 𝔗.cf_HomDom
    ]

lemmas [cat_Kan_cs_simps] = the_ntcf_rKe_components'(2-5)

end


subsubsection‹Functor: object map›

mk_VLambda the_cf_rKe_components(1)
  |vsv the_cf_rKe_ObjMap_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔄 𝔅  𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)

mk_VLambda the_cf_rKe_components'(1)[OF 𝔎 𝔗]
  |vdomain the_cf_rKe_ObjMap_vdomain[cat_Kan_cs_simps]|
  |app the_cf_rKe_ObjMap_impl_app[cat_Kan_cs_simps]|

lemma the_cf_rKe_ObjMap_vrange: 
  assumes "c. c  Obj  lim_Obj cUObj  𝔄Obj"
  shows " (the_cf_rKe α 𝔗 𝔎 lim_ObjObjMap)  𝔄Obj"
  unfolding the_cf_rKe_components'[OF 𝔎 𝔗]
  by (intro vrange_VLambda_vsubset assms)

end


subsubsection‹Functor: arrow map›

mk_VLambda the_cf_rKe_components(2)
  |vsv the_cf_rKe_ArrMap_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔅  𝔎
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)

mk_VLambda the_cf_rKe_components(2)[where α=α and 𝔎=𝔎, unfolded 𝔎.cf_HomCod]
  |vdomain the_cf_rKe_ArrMap_vdomain[cat_Kan_cs_simps]|

context 
  fixes 𝔄 𝔗 c c' g
  assumes 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and g: "g : c  c'"
begin

interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

lemma g': "g  Arr" using g by auto

mk_VLambda the_cf_rKe_components(2)[
    where α=α and 𝔎=𝔎 and 𝔗=𝔗, unfolded 𝔎.cf_HomCod 𝔗.cf_HomCod
    ]
  |app the_cf_rKe_ArrMap_app_impl'|

lemmas the_cf_rKe_ArrMap_app' = the_cf_rKe_ArrMap_app_impl'[
    OF g', unfolded 𝔎.HomCod.cat_is_arrD[OF g]
    ]

end

end

lemma the_cf_rKe_ArrMap_app_impl:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "g : c  c'"
    and "u : r <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "u' : r' <CF.lim 𝔗 CF c' OCF 𝔎 : c' CF 𝔎 ↦↦Cα 𝔄"
  shows "∃!f.
    f : r 𝔄 r' 
    u NTCF-CF g ACF 𝔎 = u' NTCF ntcf_const (c' CF 𝔎) 𝔄 f"
proof-

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  interpret u: is_cat_limit α c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 r u
    by (rule assms(4))
  interpret u': is_cat_limit α c' CF 𝔎 𝔄 𝔗 CF c' OCF 𝔎 r' u'
    by (rule assms(5))

  have const_r_def:
    "cf_const (c' CF 𝔎) 𝔄 r = cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎"
  proof(rule cf_eqI)
    show const_r: "cf_const (c' CF 𝔎) 𝔄 r : c' CF 𝔎 ↦↦Cα 𝔄"
      by (cs_concl cs_intro: cat_cs_intros cat_lim_cs_intros)
    from assms(3) show const_r_g𝔎: 
      "cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎 : c' CF 𝔎 ↦↦Cα 𝔄"
      by (cs_concl cs_intro: cat_cs_intros cat_comma_cs_intros)
    have ObjMap_dom_lhs: "𝒟 (cf_const (c' CF 𝔎) 𝔄 rObjMap) = c' CF 𝔎Obj"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from assms(3) have ObjMap_dom_rhs: 
      "𝒟 ((cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎)ObjMap) = c' CF 𝔎Obj"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_comma_cs_intros
        )
    have ArrMap_dom_lhs: "𝒟 (cf_const (c' CF 𝔎) 𝔄 rArrMap) = c' CF 𝔎Arr"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from assms(3) have ArrMap_dom_rhs: 
      "𝒟 ((cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎)ArrMap) = c' CF 𝔎Arr"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_comma_cs_intros
        )
    show 
      "cf_const (c' CF 𝔎) 𝔄 rObjMap =
        (cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎)ObjMap"
    proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
      fix A assume prems: "A  c' CF 𝔎Obj"
      from prems assms obtain b f 
        where A_def: "A = [0, b, f]"
          and b: "b  𝔅Obj" 
          and f: "f : c'  𝔎ObjMapb"
        by auto
      from assms(1,3) prems f b show 
        "cf_const (c' CF 𝔎) 𝔄 rObjMapA =
          (cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎)ObjMapA"
        unfolding A_def
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_comma_cs_simps 
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
    qed (use assms(3) in cs_concl cs_intro: cat_cs_intros cat_comma_cs_intros)+
    show
      "cf_const (c' CF 𝔎) 𝔄 rArrMap =
        (cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎)ArrMap"
    proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
      show "vsv (cf_const (c' CF 𝔎) 𝔄 rArrMap)"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      from assms(3) show "vsv ((cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎)ArrMap)"
        by (cs_concl cs_intro: cat_cs_intros cat_comma_cs_intros)
      fix F assume prems: "F  c' CF 𝔎Arr"
      with prems obtain A B where F: "F : A c' CF 𝔎 B"
        by (auto intro: is_arrI)
      with assms obtain b f b' f' h'
        where F_def: "F = [[0, b, f], [0, b', f'], [0, h']]"
          and A_def: "A = [0, b, f]"
          and B_def: "B = [0, b', f']"
          and h': "h' : b 𝔅 b'"
          and f: "f : c'  𝔎ObjMapb"
          and f': "f' : c'  𝔎ObjMapb'"
          and f'_def: "𝔎ArrMaph' A f = f'"
        by auto
      from prems assms(3) F g' h' f f' show
        "cf_const (c' CF 𝔎) 𝔄 rArrMapF =
          (cf_const (c CF 𝔎) 𝔄 r CF g ACF 𝔎)ArrMapF"
        unfolding F_def A_def B_def
        by (*slow*)
          (
            cs_concl
              cs_simp: cat_comma_cs_simps cat_cs_simps f'_def[symmetric]
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
    qed simp
  qed simp_all

  have 𝔗c'𝔎: "𝔗 CF c' OCF 𝔎 = 𝔗 CF c OCF 𝔎 CF g ACF 𝔎"
  proof(rule cf_eqI)
    show "𝔗 CF c' OCF 𝔎 : c' CF 𝔎 ↦↦Cα 𝔄"
      by (cs_concl cs_intro: cat_cs_intros)
    from assms show " 𝔗 CF c OCF 𝔎 CF g ACF 𝔎 : c' CF 𝔎 ↦↦Cα 𝔄"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps 
            cs_intro: cat_comma_cs_intros cat_cs_intros
        )
    have ObjMap_dom_lhs: "𝒟 ((𝔗 CF c' OCF 𝔎)ObjMap) = c' CF 𝔎Obj"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from assms have ObjMap_dom_rhs: 
      "𝒟 ((𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ObjMap) = c' CF 𝔎Obj"
      by
        (
          cs_concl 
            cs_simp: cat_cs_simps 
            cs_intro: cat_comma_cs_intros cat_cs_intros
        )
    show "(𝔗 CF c' OCF 𝔎)ObjMap = (𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ObjMap"
    proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
      from assms show "vsv ((𝔗 CF c' OCF 𝔎)ObjMap)"
        by
          (
            cs_concl
              cs_simp: cat_comma_cs_simps 
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
      from assms show "vsv ((𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ObjMap)"
        by (cs_concl cs_intro: cat_cs_intros cat_comma_cs_intros)
      fix A assume prems: "A  c' CF 𝔎Obj"
      from assms(3) prems obtain b f
        where A_def: "A = [0, b, f]"
          and b: "b  𝔅Obj"
          and f: "f : c'  𝔎ObjMapb"
        by auto
      from prems assms b f show 
        "(𝔗 CF c' OCF 𝔎)ObjMapA =
          (𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ObjMapA"
        unfolding A_def
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_comma_cs_simps
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
    qed simp

    have ArrMap_dom_lhs: "𝒟 ((𝔗 CF c' OCF 𝔎)ArrMap) = c' CF 𝔎Arr"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from assms have ArrMap_dom_rhs:
      "𝒟 ((𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ArrMap) = c' CF 𝔎Arr"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps
            cs_intro: cat_comma_cs_intros cat_cs_intros
        )

    show "(𝔗 CF c' OCF 𝔎)ArrMap = (𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ArrMap"
    proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
      from assms show "vsv ((𝔗 CF c' OCF 𝔎)ArrMap)"
        by
          (
            cs_concl 
              cs_simp: cat_comma_cs_simps 
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
      from assms show "vsv ((𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ArrMap)"
        by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_comma_cs_intros)

      fix F assume prems: "F  c' CF 𝔎Arr"
      with prems obtain A B where F: "F : A c' CF 𝔎 B"
        unfolding cat_comma_cs_simps by (auto intro: is_arrI)
      with assms(3) obtain b f b' f' h'
        where F_def: "F = [[0, b, f], [0, b', f'], [0, h']]"
          and A_def: "A = [0, b, f]"
          and B_def: "B = [0, b', f']"
          and h': "h' : b 𝔅 b'"
          and f: "f : c'  𝔎ObjMapb"
          and f': "f' : c'  𝔎ObjMapb'"
          and f'_def: "𝔎ArrMaph' A f = f'"
        by auto
      from prems assms(3) F g' h' f f' show
        "(𝔗 CF c' OCF 𝔎)ArrMapF =
          (𝔗 CF c OCF 𝔎 CF g ACF 𝔎)ArrMapF"
        unfolding F_def A_def B_def
        by (*slow*)
          (
            cs_concl
              cs_simp: cat_comma_cs_simps cat_cs_simps f'_def[symmetric]
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
    qed simp
  qed simp_all

  from assms(1-3) have
    "u NTCF-CF g ACF 𝔎 : r <CF.cone 𝔗 CF c' OCF 𝔎 : c' CF 𝔎 ↦↦Cα 𝔄"
    by (intro is_cat_coneI is_tm_ntcfI')
      (
        cs_concl
          cs_intro:
            cat_cs_intros
            cat_comma_cs_intros
            cat_lim_cs_intros
            cat_small_cs_intros
          cs_simp: const_r_def 𝔗c'𝔎
      )+
  with u'.cat_lim_unique_cone show
    "∃!G.
      G : r 𝔄 r' 
      u NTCF-CF g ACF 𝔎 = u' NTCF ntcf_const (c' CF 𝔎) 𝔄 G"
    by simp

qed

lemma the_cf_rKe_ArrMap_app:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "g : c  c'"
    and "lim_Obj cUArr :
      lim_Obj cUObj <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "lim_Obj c'UArr :
      lim_Obj c'UObj <CF.lim 𝔗 CF c' OCF 𝔎 : c' CF 𝔎 ↦↦Cα 𝔄"
  shows "the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapg :
    lim_Obj cUObj 𝔄 lim_Obj c'UObj"
    and
      "lim_Obj cUArr NTCF-CF g ACF 𝔎 =
        lim_Obj c'UArr NTCF
          ntcf_const (c' CF 𝔎) 𝔄 (the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapg)"
    and 
      "
        f : lim_Obj cUObj 𝔄 lim_Obj c'UObj;
        lim_Obj cUArr NTCF-CF g ACF 𝔎 =
          lim_Obj c'UArr NTCF ntcf_const (c' CF 𝔎) 𝔄 f
         f = the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapg"
proof-

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  interpret u: is_cat_limit 
    α c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 lim_Obj cUObj lim_Obj cUArr
    by (rule assms(4))
  interpret u': is_cat_limit 
    α c' CF 𝔎 𝔄 𝔗 CF c' OCF 𝔎 lim_Obj c'UObj lim_Obj c'UArr
    by (rule assms(5))

  from assms(3) have c: "c  Obj" and c': "c'  Obj" by auto

  note the_cf_rKe_ArrMap_app_impl' =
    the_cf_rKe_ArrMap_app_impl[OF assms]
  note the_f = theI'[OF the_cf_rKe_ArrMap_app_impl[OF assms]]
  note the_f_is_arr = the_f[THEN conjunct1]
    and the_f_commutes = the_f[THEN conjunct2]

  from assms(3) the_f_is_arr show
    "the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapg :
      lim_Obj cUObj 𝔄 lim_Obj c'UObj"
    by (cs_concl cs_simp: the_cf_rKe_ArrMap_app' cs_intro: cat_cs_intros)
  moreover from assms(3) the_f_commutes show
    "lim_Obj cUArr NTCF-CF g ACF 𝔎 =
      lim_Obj c'UArr NTCF
        ntcf_const (c' CF 𝔎) 𝔄 (the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapg)"
    by (cs_concl cs_simp: the_cf_rKe_ArrMap_app' cs_intro: cat_cs_intros)
  ultimately show "f = the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapg"
    if "f : lim_Obj cUObj 𝔄 lim_Obj c'UObj"
      and "lim_Obj cUArr NTCF-CF g ACF 𝔎 =
        lim_Obj c'UArr NTCF ntcf_const (c' CF 𝔎) 𝔄 f"
    by (metis that the_cf_rKe_ArrMap_app_impl')

qed

lemma the_cf_rKe_ArrMap_is_arr'[cat_Kan_cs_intros]:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "g : c  c'"
    and "lim_Obj cUArr :
      lim_Obj cUObj <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "lim_Obj c'UArr :
      lim_Obj c'UObj <CF.lim 𝔗 CF c' OCF 𝔎 : c' CF 𝔎 ↦↦Cα 𝔄"
    and "a = lim_Obj cUObj"
    and "b = lim_Obj c'UObj"
  shows "the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapg : a 𝔄 b"
  unfolding assms(6,7) by (rule the_cf_rKe_ArrMap_app[OF assms(1-5)])

lemma lim_Obj_the_cf_rKe_commute:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "lim_Obj aUArr :
      lim_Obj aUObj <CF.lim 𝔗 CF a OCF 𝔎 : a CF 𝔎 ↦↦Cα 𝔄"
    and "lim_Obj bUArr :
      lim_Obj bUObj <CF.lim 𝔗 CF b OCF 𝔎 : b CF 𝔎 ↦↦Cα 𝔄"
    and "f : a  b"
    and "[a', b', f']  b CF 𝔎Obj"
  shows  
    "lim_Obj aUArrNTMapa', b', f' A f =
      lim_Obj bUArrNTMapa', b', f' A𝔄
        the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapf" 
proof-

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))

  note f = 𝔎.HomCod.cat_is_arrD[OF assms(5)]

  interpret lim_a: is_cat_limit
    α a CF 𝔎 𝔄 𝔗 CF a OCF 𝔎 lim_Obj aUObj lim_Obj aUArr
    by (rule assms(3))
  interpret lim_b: is_cat_limit 
    α b CF 𝔎 𝔄 𝔗 CF b OCF 𝔎 lim_Obj bUObj lim_Obj bUArr 
    by (rule assms(4))

  note f_app = the_cf_rKe_ArrMap_app[
      where lim_Obj=lim_Obj, OF assms(1,2,5,3,4)
      ]

  from f_app(2) have lim_a_f𝔎_NTMap_app:
    "(lim_Obj aUArr NTCF-CF f ACF 𝔎)NTMapA =
      (
        lim_Obj bUArr NTCF
        ntcf_const (b CF 𝔎) 𝔄 (the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapf)
      )NTMapA"
    if A  b CF 𝔎Obj for A
    by simp
  show 
    "lim_Obj aUArrNTMapa', b', f' A f =
      lim_Obj bUArrNTMapa', b', f' A𝔄
        the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapf" 
  proof-
    from assms(5,6) have a'_def: "a' = 0"
      and b': "b'  𝔅Obj"
      and f': "f' : b  𝔎ObjMapb'"
      by auto
    show 
      "lim_Obj aUArrNTMapa', b', f' A f =
        lim_Obj bUArrNTMapa', b', f' A𝔄
          the_cf_rKe α 𝔗 𝔎 lim_ObjArrMapf"
      using lim_a_f𝔎_NTMap_app[OF assms(6)] f' assms(3,4,5,6) 
      unfolding a'_def
      by
        (
          cs_prems
            cs_simp: cat_cs_simps cat_comma_cs_simps cat_Kan_cs_simps
            cs_intro:
              cat_small_cs_intros
              cat_cs_intros
              cat_comma_cs_intros
              cat_Kan_cs_intros
        )      
  qed

qed


subsubsection‹Natural transformation: natural transformation map›

mk_VLambda the_ntcf_rKe_components(1)
  |vsv the_ntcf_rKe_NTMap_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔄 𝔅  𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)
interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

mk_VLambda the_ntcf_rKe_components'(1)[OF 𝔎 𝔗]
  |vdomain the_ntcf_rKe_ObjMap_vdomain[cat_Kan_cs_simps]|
  |app the_ntcf_rKe_ObjMap_impl_app[cat_Kan_cs_simps]|

end


subsubsection‹The Kan extension is a Kan extension›

lemma the_cf_rKe_is_functor:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c. c  Obj  lim_Obj cUArr :
      lim_Obj cUObj <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
  shows "the_cf_rKe α 𝔗 𝔎 lim_Obj :  ↦↦Cα 𝔄"
proof-

  let ?UObj = λa. lim_Obj aUObj 
  let ?UArr = λa. lim_Obj aUArr
  let ?const_comma = λa b. cf_const (a CF 𝔎) 𝔄 (?UObj b)
  let ?the_cf_rKe = ‹the_cf_rKe α 𝔗 𝔎 lim_Obj

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))

  note [cat_lim_cs_intros] = is_cat_cone.cat_cone_obj
  
  show ?thesis
  proof(intro is_functorI')

    show "vfsequence ?the_cf_rKe" unfolding the_cf_rKe_def by simp
    show "vcard ?the_cf_rKe = 4" 
      unfolding the_cf_rKe_def by (simp add: nat_omega_simps)
    show "vsv (?the_cf_rKeObjMap)" by (cs_concl cs_intro: cat_Kan_cs_intros)
    moreover show "𝒟 (?the_cf_rKeObjMap) = Obj"
      by (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)
    moreover show " (?the_cf_rKeObjMap)  𝔄Obj"
    proof
      (
        intro the_cf_rKe_ObjMap_vrange; 
        (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)?
      )
      fix c assume "c  Obj"
      with assms(3)[OF this] show "?UObj c  𝔄Obj"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_lim_cs_intros)
    qed
    ultimately have [cat_Kan_cs_intros]: 
      "?the_cf_rKeObjMapc  𝔄Obj" if c  Obj for c
      by (metis that vsubsetE vsv.vsv_value)

    show "?the_cf_rKeArrMapf :
      ?the_cf_rKeObjMapa 𝔄 ?the_cf_rKeObjMapb"
      if "f : a  b" for a b f
      using assms(2) that
      by 
        (
          cs_concl
            cs_simp: cat_Kan_cs_simps 
            cs_intro: 
              assms(3) cat_small_cs_intros cat_cs_intros cat_Kan_cs_intros
        )
    then have [cat_Kan_cs_intros]: "?the_cf_rKeArrMapf : A 𝔄 B"
      if "A = ?the_cf_rKeObjMapa" 
        and "B = ?the_cf_rKeObjMapb"
        and "f : a  b" 
      for A B a b f
      by (simp add: that)

    show
      "?the_cf_rKeArrMapg A f =
        ?the_cf_rKeArrMapg A𝔄 ?the_cf_rKeArrMapf"
      (is ?the_cf_rKeArrMapg A f = ?the_rKe_g A𝔄 ?the_rKe_f)
      if g_is_arr: "g : b  c" and f_is_arr: "f : a  b" for b c g a f
    proof-

      let ?ntcf_const_c = λf. ntcf_const (c CF 𝔎) 𝔄 f

      note g = 𝔎.HomCod.cat_is_arrD[OF that(1)]
        and f = 𝔎.HomCod.cat_is_arrD[OF that(2)]
      note lim_a = assms(3)[OF f(2)]
        and lim_b = assms(3)[OF g(2)]
        and lim_c = assms(3)[OF g(3)]
      from that have gf: "g A f : a  c" 
        by (cs_concl cs_intro: cat_cs_intros)

      interpret lim_a: is_cat_limit
        α a CF 𝔎 𝔄 𝔗 CF a OCF 𝔎 ?UObj a ?UArr a
        by (rule lim_a)
      interpret lim_c: is_cat_limit
        α c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ?UObj c ?UArr c
        by (rule lim_c)

      show ?thesis
      proof
        (
          rule sym, 
          rule the_cf_rKe_ArrMap_app(3)[OF assms(1,2) gf lim_a lim_c]
        )

        from assms(1,2) that lim_a lim_b lim_c show 
          "?the_rKe_g A𝔄 ?the_rKe_f : ?UObj a 𝔄 ?UObj c"
          by
            (
              cs_concl
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
            )
      
        show
          "?UArr a NTCF-CF (g A f) ACF 𝔎 = 
            ?UArr c NTCF ?ntcf_const_c (?the_rKe_g A𝔄 ?the_rKe_f)"
          (
            is 
              ?UArr a NTCF-CF (g A f) ACF 𝔎 =
                  ?UArr c NTCF ?ntcf_const_c ?the_rKe_gf
           )
        proof(rule ntcf_eqI)
          from that show 
            "?UArr a NTCF-CF (g A f) ACF 𝔎 :
              cf_const (a CF 𝔎) 𝔄 (?UObj a) CF (g A f) ACF 𝔎 CF
              𝔗 CF a OCF 𝔎 CF ((g A f) ACF 𝔎) :
              c CF 𝔎 ↦↦Cα 𝔄"
            by (cs_concl cs_intro: cat_cs_intros cat_comma_cs_intros)
          have [cat_comma_cs_simps]: 
            "?const_comma a a CF (g A f) ACF 𝔎 = ?const_comma c a"
          proof(rule cf_eqI)
            from g_is_arr f_is_arr show
              "?const_comma a a CF (g A f) ACF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
              by
                (
                  cs_concl
                    cs_simp: cat_comma_cs_simps cat_cs_simps
                    cs_intro: 
                      cat_cs_intros cat_lim_cs_intros cat_comma_cs_intros
                )
            from g_is_arr f_is_arr show "?const_comma c a : c CF 𝔎 ↦↦Cα 𝔄"
              by
                (
                  cs_concl
                    cs_simp: cat_comma_cs_simps cat_cs_simps
                    cs_intro: 
                      cat_cs_intros cat_lim_cs_intros cat_comma_cs_intros
                )
            from g_is_arr f_is_arr have ObjMap_dom_lhs:
              "𝒟 ((?const_comma a a CF (g A f) ACF 𝔎)ObjMap) =
                c CF 𝔎Obj"
              by
                (
                  cs_concl
                    cs_simp: cat_comma_cs_simps cat_cs_simps 
                    cs_intro: 
                      cat_comma_cs_intros cat_lim_cs_intros cat_cs_intros
                )
            from g_is_arr f_is_arr have ObjMap_dom_rhs:
              "𝒟 (?const_comma c aObjMap) = c CF 𝔎Obj"
              by (cs_concl cs_simp: cat_comma_cs_simps cat_cs_simps)

            show
              "(?const_comma a a CF (g A f) ACF 𝔎)ObjMap =
                ?const_comma c aObjMap"
            proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
              from f_is_arr g_is_arr show 
                "vsv ((?const_comma a a CF (g A f) ACF 𝔎)ObjMap)"
                by
                  (
                    cs_concl
                      cs_simp: cat_comma_cs_simps cat_cs_simps 
                      cs_intro:
                        cat_cs_intros cat_lim_cs_intros cat_comma_cs_intros
                  )
              fix A assume prems: "A  c CF 𝔎Obj"
              with g_is_arr obtain b' f' 
                where A_def: "A = [0, b', f']"
                  and b': "b'  𝔅Obj"
                  and f': "f' : c  𝔎ObjMapb'"
                by auto
              from prems b' f' g_is_arr f_is_arr show 
                "(?const_comma a a CF (g A f) ACF 𝔎)ObjMapA =
                  ?const_comma c aObjMapA"
                unfolding A_def
                by
                  (
                    cs_concl
                      cs_simp: cat_comma_cs_simps cat_cs_simps 
                      cs_intro:
                        cat_cs_intros cat_lim_cs_intros cat_comma_cs_intros
                  )
            qed (cs_concl cs_intro: cat_cs_intros)

            from g_is_arr f_is_arr have ArrMap_dom_lhs:
              "𝒟 ((?const_comma a a CF (g A f) ACF 𝔎)ArrMap) = 
                c CF 𝔎Arr"
              by
                (
                  cs_concl
                    cs_simp: cat_comma_cs_simps cat_cs_simps 
                    cs_intro: 
                      cat_comma_cs_intros cat_lim_cs_intros cat_cs_intros
                )
            from g_is_arr f_is_arr have ArrMap_dom_rhs:
              "𝒟 (?const_comma c aArrMap) = c CF 𝔎Arr"
              by (cs_concl cs_simp: cat_comma_cs_simps cat_cs_simps)

            show 
              "(?const_comma a a CF (g A f) ACF 𝔎)ArrMap =
                ?const_comma c aArrMap"
            proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
              from f_is_arr g_is_arr show
                "vsv ((?const_comma a a CF (g A f) ACF 𝔎)ArrMap)"
                by
                  (
                    cs_concl
                      cs_simp: cat_comma_cs_simps cat_cs_simps
                      cs_intro:
                        cat_cs_intros cat_lim_cs_intros cat_comma_cs_intros
                  )
              fix F assume "F  c CF 𝔎Arr"
              then obtain A B where F: "F : A c CF 𝔎 B"
                unfolding cat_comma_cs_simps by (auto intro: is_arrI)
              with g_is_arr obtain b' f' b'' f'' h'
                where F_def: "F = [[0, b', f'], [0, b'', f''], [0, h']]"
                  and A_def: "A = [0, b', f']"
                  and B_def: "B = [0, b'', f'']"
                  and h': "h' : b' 𝔅 b''"
                  and f': "f' : c  𝔎ObjMapb'"
                  and f'': "f'' : c  𝔎ObjMapb''"
                  and f''_def: "𝔎ArrMaph' A f' = f''"
                by auto
              from F f_is_arr g_is_arr g' h' f' f'' show 
                "(?const_comma a a CF (g A f) ACF 𝔎)ArrMapF =
                  ?const_comma c aArrMapF"
                unfolding F_def A_def B_def
                by
                  (
                    cs_concl
                      cs_intro:
                        cat_lim_cs_intros cat_cs_intros cat_comma_cs_intros
                      cs_simp: 
                        cat_cs_simps cat_comma_cs_simps f''_def[symmetric]
                  )
            qed (cs_concl cs_intro: cat_cs_intros)
          qed simp_all

          from that show
            "?UArr c NTCF ?ntcf_const_c ?the_rKe_gf :
              cf_const (a CF 𝔎) 𝔄 (?UObj a) CF (g A f) ACF 𝔎 CF
              𝔗 CF a OCF 𝔎 CF ((g A f) ACF 𝔎) :
              c CF 𝔎 ↦↦Cα 𝔄"
            by
              (
                cs_concl
                  cs_simp: cat_Kan_cs_simps cat_comma_cs_simps cat_cs_simps 
                  cs_intro: cat_comma_cs_intros cat_Kan_cs_intros cat_cs_intros
              )
          from that have dom_lhs:
            "𝒟 ((?UArr a NTCF-CF (g A f) ACF 𝔎)NTMap) = c CF 𝔎Obj"
            by
              (
                cs_concl
                  cs_intro: cat_cs_intros cat_comma_cs_intros
                  cs_simp: cat_cs_simps cat_comma_cs_simps
              )
          from that have dom_rhs: 
            "𝒟 ((?UArr c NTCF ?ntcf_const_c ?the_rKe_gf)NTMap) = 
              c CF 𝔎Obj"
            by
              (
                cs_concl
                  cs_intro: cat_cs_intros cat_Kan_cs_intros cat_comma_cs_intros
                  cs_simp: cat_Kan_cs_simps cat_cs_simps cat_comma_cs_simps
              )
          show 
            "(?UArr a NTCF-CF (g A f) ACF 𝔎)NTMap =
              (?UArr c NTCF ?ntcf_const_c ?the_rKe_gf)NTMap"
          proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
            fix A assume prems: "A  c CF 𝔎Obj"
            with g_is_arr obtain b' f' 
              where A_def: "A = [0, b', f']"
                and b': "b'  𝔅Obj"
                and f': "f' : c  𝔎ObjMapb'"
              by auto
            note 𝔗.HomCod.cat_Comp_assoc[cat_cs_simps del]
              and 𝔎.HomCod.cat_Comp_assoc[cat_cs_simps del]
              and category.cat_Comp_assoc[cat_cs_simps del]
            note [symmetric, cat_cs_simps] =
              lim_Obj_the_cf_rKe_commute[where lim_Obj=lim_Obj]
              𝔎.HomCod.cat_Comp_assoc  
              𝔗.HomCod.cat_Comp_assoc
            from assms(1,2) that prems lim_a lim_b lim_c b' f' show
              "(?UArr a NTCF-CF (g A f) ACF 𝔎)NTMapA =
                (?UArr c NTCF ?ntcf_const_c ?the_rKe_gf)NTMapA"
              unfolding A_def
              by (*very slow*)
                (
                  cs_concl
                    cs_simp:
                      cat_cs_simps cat_Kan_cs_simps cat_comma_cs_simps 
                    cs_intro: 
                      cat_cs_intros cat_Kan_cs_intros cat_comma_cs_intros
                )+
          qed (cs_concl cs_simp: cs_intro: cat_cs_intros)+
        qed simp_all
      qed
    qed
    
    show "?the_cf_rKeArrMapCIdc = 𝔄CId?the_cf_rKeObjMapc"
      if "c  Obj" for c
    proof-

      let ?ntcf_const_c = ‹ntcf_const (c CF 𝔎) 𝔄 (𝔄CId?UObj c)

      note lim_c = assms(3)[OF that]

      from that have CId_c: "CIdc : c  c" 
        by (cs_concl cs_intro: cat_cs_intros)

      interpret lim_c: is_cat_limit 
        α c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ?UObj c ?UArr c
        by (rule lim_c)

      show ?thesis
      proof
        (
          rule sym,
          rule the_cf_rKe_ArrMap_app(3)[
            where lim_Obj=lim_Obj, OF assms(1,2) CId_c lim_c lim_c
            ]
        )
        from that lim_c show 
          "𝔄CId?the_cf_rKeObjMapc : ?UObj c 𝔄 ?UObj c"
          by 
            (
              cs_concl
                cs_simp: cat_Kan_cs_simps
                cs_intro: cat_cs_intros cat_lim_cs_intros
            )
        have "?UArr c NTCF-CF (CIdc) ACF 𝔎 =  ?UArr c NTCF ?ntcf_const_c"
        proof(rule ntcf_eqI)
          from lim_c that show 
            "?UArr c NTCF-CF (CIdc) ACF 𝔎 :
              cf_const (c CF 𝔎) 𝔄 (?UObj c) CF (CIdc) ACF 𝔎 CF
              𝔗 CF c OCF 𝔎 CF (CIdc) ACF 𝔎 :
              c CF 𝔎 ↦↦Cα 𝔄"
            by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_comma_cs_intros)
          from lim_c that show 
            "?UArr c NTCF ?ntcf_const_c :
               cf_const (c CF 𝔎) 𝔄 (?UObj c) CF (CIdc) ACF 𝔎 CF
               𝔗 CF c OCF 𝔎 CF (CIdc) ACF 𝔎 :
               c CF 𝔎 ↦↦Cα 𝔄"
            by 
              (
                cs_concl 
                  cs_intro: cat_cs_intros cat_lim_cs_intros 
                  cs_simp: 𝔎.cf_cf_arr_comma_CId cat_cs_simps
              )
          from that have dom_lhs:
            "𝒟 ((?UArr c NTCF-CF (CIdc) ACF 𝔎)NTMap) = c CF 𝔎Obj"
            by 
              (
                cs_concl 
                  cs_simp: cat_cs_simps 
                  cs_intro: cat_cs_intros cat_comma_cs_intros
              )
          from that have dom_rhs:
            "𝒟 ((?UArr c NTCF ?ntcf_const_c)NTMap) = c CF 𝔎Obj"
            by
              (
                cs_concl
                  cs_intro: cat_lim_cs_intros cat_cs_intros 
                  cs_simp: cat_cs_simps
              )
          show 
            "(?UArr c NTCF-CF (CIdc) ACF 𝔎)NTMap =
              (?UArr c NTCF ?ntcf_const_c)NTMap"
          proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
            fix A assume prems: "A  c CF 𝔎Obj"
            with that obtain b f 
              where A_def: "A = [0, b, f]"
                and b: "b  𝔅Obj" 
                and f: "f : c  𝔎ObjMapb"
              by auto
            from that prems f have 
              "?UArr cNTMap0, b, f : ?UObj c 𝔄 𝔗ObjMapb"
              unfolding A_def
              by
                (
                  cs_concl
                    cs_simp: cat_cs_simps cat_comma_cs_simps 
                    cs_intro: cat_comma_cs_intros cat_cs_intros
                )
            from that prems f show 
              "(?UArr c NTCF-CF (CIdc) ACF 𝔎)NTMapA =
                (?UArr c NTCF ?ntcf_const_c)NTMapA"
              unfolding A_def 
              by
                (
                  cs_concl
                    cs_simp: cat_cs_simps cat_comma_cs_simps
                    cs_intro: 
                      cat_lim_cs_intros cat_comma_cs_intros cat_cs_intros
                )
          qed (cs_concl cs_intro: cat_cs_intros)
        qed simp_all

        with that show 
          "?UArr c NTCF-CF (CIdc) ACF 𝔎 = 
            ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 (𝔄CId?the_cf_rKeObjMapc)"
          by (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)

      qed

    qed

  qed
    (
      cs_concl
        cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed

lemma the_ntcf_rKe_is_ntcf:
  assumes "𝔎 : 𝔅 ↦↦C.tmα " 
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c. c  Obj  lim_Obj cUArr : 
      lim_Obj cUObj <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
  shows "the_ntcf_rKe α 𝔗 𝔎 lim_Obj :
    the_cf_rKe α 𝔗 𝔎 lim_Obj CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄"
proof-

  let ?UObj = λa. lim_Obj aUObj 
  let ?UArr = λa. lim_Obj aUArr
  let ?const_comma = λa b. cf_const (a CF 𝔎) 𝔄 (?UObj b)
  let ?the_cf_rKe = ‹the_cf_rKe α 𝔗 𝔎 lim_Obj
  let ?the_ntcf_rKe = ‹the_ntcf_rKe α 𝔗 𝔎 lim_Obj

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  interpret cf_rKe: is_functor α  𝔄 ?the_cf_rKe
    by (rule the_cf_rKe_is_functor[OF assms, simplified])

  show ?thesis
  proof(rule is_ntcfI')
    show "vfsequence ?the_ntcf_rKe" unfolding the_ntcf_rKe_def by simp
    show "vcard ?the_ntcf_rKe = 5"
      unfolding the_ntcf_rKe_def by (simp add: nat_omega_simps)
    show "?the_ntcf_rKeNTMapb : 
      (?the_cf_rKe CF 𝔎)ObjMapb 𝔄 𝔗ObjMapb"
      if "b  𝔅Obj" for b
    proof-
      let ?𝔎b = 𝔎ObjMapb
      from that have 𝔎b: "𝔎ObjMapb  Obj"
        by (cs_concl cs_intro: cat_cs_intros)
      note lim_𝔎b = assms(3)[OF 𝔎b]
      interpret lim_𝔎b: is_cat_limit 
        α ?𝔎b CF 𝔎 𝔄 𝔗 CF ?𝔎b OCF 𝔎 ?UObj ?𝔎b ?UArr ?𝔎b
        by (rule lim_𝔎b)
      from that lim_𝔎b show ?thesis
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_comma_cs_simps cat_Kan_cs_simps
              cs_intro: cat_cs_intros cat_comma_cs_intros cat_Kan_cs_intros
          )+
    qed
    show 
      "?the_ntcf_rKeNTMapb A𝔄 (?the_cf_rKe CF 𝔎)ArrMapf =
        𝔗ArrMapf A𝔄 ?the_ntcf_rKeNTMapa"
      if "f : a 𝔅 b" for a b f 
    proof-
      let ?𝔎a = 𝔎ObjMapa and ?𝔎b = 𝔎ObjMapb and ?𝔎f = 𝔎ArrMapf
      from that have 𝔎a: "?𝔎a  Obj" 
        and 𝔎b: "?𝔎b  Obj"
        and 𝔎f: "?𝔎f : ?𝔎a  ?𝔎b"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+
      note lim_𝔎a = assms(3)[OF 𝔎a]
        and lim_𝔎b = assms(3)[OF 𝔎b]
      from that have z_b_𝔎b: "[0, b, CId?𝔎b]  ?𝔎b CF 𝔎Obj"
        by (cs_concl cs_intro: cat_cs_intros cat_comma_cs_intros)
      from 
        lim_Obj_the_cf_rKe_commute[
          OF assms(1,2) lim_𝔎a lim_𝔎b 𝔎f z_b_𝔎b, symmetric
          ]
        that
      have [cat_Kan_cs_simps]:
        "?UArr ?𝔎bNTMap0, b, CId?𝔎b A𝔄 ?the_cf_rKeArrMap?𝔎f =
          ?UArr ?𝔎aNTMap0, b, ?𝔎f"
        by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      interpret lim_𝔎a: is_cat_limit
        α ?𝔎a CF 𝔎 𝔄 𝔗 CF ?𝔎a OCF 𝔎 ?UObj ?𝔎a ?UArr ?𝔎a
        by (rule lim_𝔎a)
      interpret lim_𝔎b: is_cat_limit 
        α ?𝔎b CF 𝔎 𝔄 𝔗 CF ?𝔎b OCF 𝔎 ?UObj ?𝔎b ?UArr ?𝔎b
        by (rule lim_𝔎b)
      from that have 
        "[[0, a, CId?𝔎a], [0, b, ?𝔎f], [0, f]] :
          [0, a, CId?𝔎a] (?𝔎a) CF 𝔎 [0, b, ?𝔎f]"
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_comma_cs_simps
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
      from lim_𝔎a.ntcf_Comp_commute[OF this, symmetric] that
      have [cat_Kan_cs_simps]:
        "𝔗ArrMapf A𝔄 ?UArr (?𝔎a)NTMap 0, a, CId?𝔎a =
          ?UArr ?𝔎aNTMap0, b, ?𝔎f"
        by
          (
            cs_prems
              cs_simp: cat_cs_simps cat_comma_cs_simps
              cs_intro: cat_cs_intros cat_comma_cs_intros 𝒵.cat_1_is_arrI
          )
      from that show ?thesis
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps cat_Kan_cs_simps cs_intro: cat_cs_intros
          )
    qed
  qed
    (
      cs_concl
        cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed

lemma the_ntcf_rKe_is_cat_rKe:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c. c  Obj  lim_Obj cUArr :
      lim_Obj cUObj <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
  shows "the_ntcf_rKe α 𝔗 𝔎 lim_Obj :
    the_cf_rKe α 𝔗 𝔎 lim_Obj CF 𝔎 CF.rKeα 𝔗 : 𝔅 C  C 𝔄"
proof-

  let ?UObj = λa. lim_Obj aUObj 
  let ?UArr = λa. lim_Obj aUArr
  let ?the_cf_rKe = ‹the_cf_rKe α 𝔗 𝔎 lim_Obj
  let ?the_ntcf_rKe = ‹the_ntcf_rKe α 𝔗 𝔎 lim_Obj

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  interpret cf_rKe: is_functor α  𝔄 ?the_cf_rKe
    by (rule the_cf_rKe_is_functor[OF assms, simplified])
  interpret ntcf_rKe: is_ntcf α 𝔅 𝔄 ?the_cf_rKe CF 𝔎 𝔗 ?the_ntcf_rKe
    by (intro the_ntcf_rKe_is_ntcf assms(3))
      (cs_concl cs_intro: cat_cs_intros cat_small_cs_intros)+

  show ?thesis
  proof(rule is_cat_rKeI')

    fix 𝔊 ε assume prems: 
      "𝔊 :  ↦↦Cα 𝔄" "ε : 𝔊 CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄"

    interpret 𝔊: is_functor α  𝔄 𝔊 by (rule prems(1))
    interpret ε: is_ntcf α 𝔅 𝔄 𝔊 CF 𝔎 𝔗 ε by (rule prems(2))

    define ε' where "ε' c =
      [
        (λAc CF 𝔎Obj. εNTMapA1 A𝔄 𝔊ArrMapA2),
        cf_const (c CF 𝔎) 𝔄 (𝔊ObjMapc),
        𝔗 CF c OCF 𝔎,
        c CF 𝔎,
        𝔄
      ]"
      for c

    have ε'_components: 
      "ε' cNTMap = (λAc CF 𝔎Obj. εNTMapA1 A𝔄 𝔊ArrMapA2)"
      "ε' cNTDom = cf_const (c CF 𝔎) 𝔄 (𝔊ObjMapc)"
      "ε' cNTCod = 𝔗 CF c OCF 𝔎"
      "ε' cNTDGDom = c CF 𝔎"
      "ε' cNTDGCod = 𝔄"
      for c 
      unfolding ε'_def nt_field_simps by (simp_all add: nat_omega_simps)
    note [cat_Kan_cs_simps] = ε'_components(2-5)
    have [cat_Kan_cs_simps]: "ε' cNTMapA = εNTMapb A𝔄 𝔊ArrMapf"
      if "A = [a, b, f]" and "[a, b, f]  c CF 𝔎Obj" for A a b c f
      using that unfolding ε'_components by (auto simp: nat_omega_simps)

    have ε': "ε' c : 𝔊ObjMapc <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
      and ε'_unique: "∃!f'.
        f' : 𝔊ObjMapc 𝔄 ?UObj c 
        ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 f'" 
      if c: "c  Obj" for c
    proof-
      from that have "?the_cf_rKeObjMapc = ?UObj c"
        by (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)
      interpret lim_c: is_cat_limit 
        α c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ?UObj c ?UArr c
        by (rule assms(3)[OF that])
      show "ε' c : 𝔊ObjMapc <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
      proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')
        show "vfsequence (ε' c)" unfolding ε'_def by simp
        show "vcard (ε' c) = 5" unfolding ε'_def by (simp add: nat_omega_simps)
        show "vsv (ε' cNTMap)" unfolding ε'_components by simp 
        show "𝒟 (ε' cNTMap) = c CF 𝔎Obj" unfolding ε'_components by simp
        show "ε' cNTMapA :
          cf_const (c CF 𝔎) 𝔄 (𝔊ObjMapc)ObjMapA 𝔄
          (𝔗 CF c OCF 𝔎)ObjMapA"
          if "A  c CF 𝔎Obj" for A
        proof-
          from that prems c obtain b f 
            where A_def: "A = [0, b, f]"
              and b: "b  𝔅Obj" 
              and f: "f : c  𝔎ObjMapb"
            by auto
          from that prems f c that b f show ?thesis
            unfolding A_def
            by
              (
                cs_concl
                  cs_simp: cat_cs_simps cat_Kan_cs_simps cat_comma_cs_simps
                  cs_intro: cat_cs_intros cat_comma_cs_intros
              )
        qed
        show
          "ε' cNTMapB A𝔄 cf_const (c CF 𝔎) 𝔄 (𝔊ObjMapc)ArrMapF =
            (𝔗 CF c OCF 𝔎)ArrMapF A𝔄 ε' cNTMapA"
          if "F : A c CF 𝔎 B" for A B F
        proof-
          from that c 
          obtain b f b' f' k 
            where F_def: "F = [[0, b, f], [0, b', f'], [0, k]]"
              and A_def: "A = [0, b, f]"
              and B_def: "B = [0, b', f']"
              and k: "k : b 𝔅 b'"
              and f: "f : c  𝔎ObjMapb"
              and f': "f' : c  𝔎ObjMapb'"
              and f'_def: "𝔎ArrMapk A f = f'"
            by auto
          from c that k f f' show ?thesis
            unfolding F_def A_def B_def
            by (*slow*)
              (
                cs_concl
                  cs_simp:
                    cat_cs_simps
                    cat_comma_cs_simps
                    cat_Kan_cs_simps
                    ε.ntcf_Comp_commute''
                    f'_def[symmetric]
                  cs_intro: cat_cs_intros cat_comma_cs_intros
              )
        qed
      qed
        (
          use c that in
            cs_concl
                cs_simp: cat_Kan_cs_simps
                cs_intro: cat_small_cs_intros cat_cs_intros
        )+
      from is_cat_limit.cat_lim_unique_cone[OF assms(3)[OF that] this] show 
        "∃!f'.
          f' : 𝔊ObjMapc 𝔄 ?UObj c 
          ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 f'"  
        by simp
    qed

    define σ :: V where
      "σ =
        [
          (
            λcObj. THE f.
              f : 𝔊ObjMapc 𝔄 ?UObj c 
              ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 f
          ),
          𝔊,
          ?the_cf_rKe,
          ,
          𝔄
        ]"

    have σ_components:
      "σNTMap =
        (
          λcObj. THE f.
            f : 𝔊ObjMapc 𝔄 ?UObj c 
            ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 f
        )"
      "σNTDom = 𝔊"
      "σNTCod = ?the_cf_rKe"
      "σNTDGDom = "
      "σNTDGCod = 𝔄"
      unfolding σ_def nt_field_simps by (simp_all add: nat_omega_simps)

    note [cat_Kan_cs_simps] = σ_components(2-5)

    have σ_NTMap_app_def: "σNTMapc =
      (
        THE f.
          f : 𝔊ObjMapc 𝔄 ?UObj c 
          ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 f
      )"
      if "c  Obj" for c
      using that unfolding σ_components by simp

    have σ_NTMap_app_is_arr: "σNTMapc : 𝔊ObjMapc 𝔄 ?UObj c"
      and ε'_σ_commute:
        "ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 (σNTMapc)"
      and σ_NTMap_app_unique:
        "
          f : 𝔊ObjMapc 𝔄 ?UObj c;
          ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 f
           f = σNTMapc"
        if c: "c  Obj" for c f
    proof-
      have 
        "σNTMapc : 𝔊ObjMapc 𝔄 ?UObj c 
        ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 (σNTMapc)"
        by 
          (
            cs_concl 
              cs_simp: cat_Kan_cs_simps σ_NTMap_app_def 
              cs_intro: theI' ε'_unique that
          )
      then show "σNTMapc : 𝔊ObjMapc 𝔄 ?UObj c"
        and "ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 (σNTMapc)"
        by simp_all
      with c ε'_unique[OF c] show "f = σNTMapc"
        if "f : 𝔊ObjMapc 𝔄 ?UObj c"
          and "ε' c = ?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 f"
        using that by metis
    qed

    have σ_NTMap_app_is_arr'[cat_Kan_cs_intros]: "σNTMapc : a 𝔄' b"
      if "c  Obj" 
        and "a = 𝔊ObjMapc" 
        and "b = ?UObj c" 
        and "𝔄' = 𝔄"
      for 𝔄' a b c
      by (simp add: that σ_NTMap_app_is_arr)

    have ε'_NTMap_app_def: 
      "ε' cNTMapA =
        (?UArr c NTCF ntcf_const (c CF 𝔎) 𝔄 (σNTMapc))NTMapA"
      if "A  c CF 𝔎Obj" and "c  Obj" for A c
      using ε'_σ_commute[OF that(2)] by simp
    have εb_𝔊f:
      "εNTMapb A𝔄 𝔊ArrMapf =
        ?UArr cNTMapa, b, f A𝔄 σNTMapc"
      if "A = [a, b, f]" and "A  c CF 𝔎Obj" and "c  Obj" 
      for A a b c f
    proof-
      interpret lim_c: is_cat_limit 
        α c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ?UObj c ?UArr c
        by (rule assms(3)[OF that(3)])
      from that have b: "b  𝔅Obj" and f: "f : c  𝔎ObjMapb"
        by blast+
      show
        "εNTMapb A𝔄 𝔊ArrMapf =
          ?UArr cNTMapa, b, f A𝔄 σNTMapc"
        using ε'_NTMap_app_def[OF that(2,3)] that(2,3)
        unfolding that(1)
        by
          (
            cs_prems
              cs_simp: cat_cs_simps cat_Kan_cs_simps
              cs_intro: cat_cs_intros cat_Kan_cs_intros
          )
    qed

    show "∃!σ.
      σ : 𝔊 CF ?the_cf_rKe :  ↦↦Cα 𝔄 
      ε = ?the_ntcf_rKe NTCF (σ NTCF-CF 𝔎)"
    proof(intro ex1I[where a=σ] conjI; (elim conjE)?)

      define τ where "τ a b f =
        [
          (
            λFb CF 𝔎Obj.
              ?UArr bNTMapF A𝔄 σNTMapb A𝔄 𝔊ArrMapf
          ),
          cf_const (b CF 𝔎) 𝔄 (𝔊ObjMapa),
          𝔗 CF b OCF 𝔎,
          b CF 𝔎,
          𝔄
        ]"
        for a b f

      have τ_components:
        "τ a b fNTMap =
          (
            λFb CF 𝔎Obj.
              ?UArr bNTMapF A𝔄 σNTMapb A𝔄 𝔊ArrMapf
          )"
        "τ a b fNTDom = cf_const (b CF 𝔎) 𝔄 (𝔊ObjMapa)"
        "τ a b fNTCod = 𝔗 CF b OCF 𝔎"
        "τ a b fNTDGDom = b CF 𝔎"
        "τ a b fNTDGCod = 𝔄"
        for a b f
        unfolding τ_def nt_field_simps by (simp_all add: nat_omega_simps)
      note [cat_Kan_cs_simps] = τ_components(2-5)
      have τ_NTMap_app[cat_Kan_cs_simps]: 
        "τ a b fNTMapF =
          ?UArr bNTMapF A𝔄 σNTMapb A𝔄 𝔊ArrMapf"
        if "F  b CF 𝔎Obj" for a b f F
        using that unfolding τ_components by auto
      
      have τ: "τ a b f :
        𝔊ObjMapa <CF.cone 𝔗 CF b OCF 𝔎 : b CF 𝔎 ↦↦Cα 𝔄"
        if f_is_arr: "f : a  b" for a b f
      proof-

        note f = 𝔎.HomCod.cat_is_arrD[OF that]
        note lim_a = assms(3)[OF f(2)] and lim_b = assms(3)[OF f(3)]

        interpret lim_b: is_cat_limit 
          α b CF 𝔎 𝔄 𝔗 CF b OCF 𝔎 ?UObj b ?UArr b
          by (rule lim_b)
        
        from f have a: "a  Obj" and b: "b  Obj" by auto

        show ?thesis
        proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')

          show "vfsequence (τ a b f)" unfolding τ_def by simp
          show "vcard (τ a b f) = 5" 
            unfolding τ_def by (simp add: nat_omega_simps)
          show "vsv (τ a b fNTMap)" unfolding τ_components by auto
          show "𝒟 (τ a b fNTMap) = b CF 𝔎Obj" by (auto simp: τ_components)
          show "τ a b fNTMapA :
            cf_const (b CF 𝔎) 𝔄 (𝔊ObjMapa)ObjMapA 𝔄
            (𝔗 CF b OCF 𝔎)ObjMapA"
            if "A  b CF 𝔎Obj" for A
          proof-
            from that f_is_arr obtain b' f' 
              where A_def: "A = [0, b', f']"
                and b': "b'  𝔅Obj"
                and f': "f' : b  𝔎ObjMapb'"
              by auto
            from  f_is_arr that b' f' a b show ?thesis
              unfolding A_def
              by
                (
                  cs_concl
                    cs_simp: cat_cs_simps cat_comma_cs_simps cat_Kan_cs_simps
                    cs_intro: cat_cs_intros cat_comma_cs_intros cat_Kan_cs_intros
                )   
          qed
          show
            "τ a b fNTMapB A𝔄
              cf_const (b CF 𝔎) 𝔄 (𝔊ObjMapa)ArrMapF =
              (𝔗 CF b OCF 𝔎)ArrMapF A𝔄 τ a b fNTMapA"
            if "F : A b CF 𝔎 B" for A B F
          proof-
            from that have F: "F : A b CF 𝔎 B"
              by (auto intro: is_arrI)
            with f_is_arr obtain b' f' b'' f'' h'
              where F_def: "F = [[0, b', f'], [0, b'', f''], [0, h']]"
                and A_def: "A = [0, b', f']"
                and B_def: "B = [0, b'', f'']"
                and h': "h' : b' 𝔅 b''"
                and f': "f' : b  𝔎ObjMapb'"
                and f'': "f'' : b  𝔎ObjMapb''"
                and f''_def: "𝔎ArrMaph' A f' = f''"
              by auto
            from
              lim_b.ntcf_Comp_commute[OF that] 
              that f_is_arr g' h' f' f'' 
            have [cat_Kan_cs_simps]:
              "?UArr bNTMap0, b'', 𝔎ArrMaph' A f' =
                𝔗ArrMaph' A𝔄 ?UArr bNTMap0, b', f'"
              unfolding F_def A_def B_def
              by
                (
                  cs_prems
                    cs_simp: 
                      cat_cs_simps cat_comma_cs_simps f''_def[symmetric]
                    cs_intro: cat_cs_intros cat_comma_cs_intros
                )
            from f_is_arr that g' h' f' f'' show ?thesis
              unfolding F_def A_def B_def (*very slow*)
              by
                (
                  cs_concl
                    cs_simp:
                      cat_cs_simps 
                      cat_Kan_cs_simps 
                      cat_comma_cs_simps 
                      f''_def[symmetric]
                    cs_intro:
                      cat_cs_intros cat_Kan_cs_intros cat_comma_cs_intros
                )+
          qed

        qed
          (
            use that f_is_arr in
              cs_concl
                  cs_simp: cat_cs_simps cat_Kan_cs_simps
                  cs_intro: cat_small_cs_intros cat_cs_intros
          )+
      qed

      show σ: "σ : 𝔊 CF ?the_cf_rKe :  ↦↦Cα 𝔄"
      proof(rule is_ntcfI')

        show "vfsequence σ" unfolding σ_def by simp
        show "vcard σ = 5" unfolding σ_def by (simp add: nat_omega_simps)
        show "vsv (σNTMap)" unfolding σ_components by auto
        show "𝒟 (σNTMap) = Obj" unfolding σ_components by simp
        show "σNTMapa : 𝔊ObjMapa 𝔄 ?the_cf_rKeObjMapa"
          if "a  Obj" for a
          using that 
          by
            (
              cs_concl
                cs_simp: cat_cs_simps cat_Kan_cs_simps
                cs_intro: cat_cs_intros cat_Kan_cs_intros
            )

        then have [cat_Kan_cs_intros]: "σNTMapa : b 𝔄 c"
          if "a  Obj" 
            and "b = 𝔊ObjMapa" 
            and "c = ?the_cf_rKeObjMapa"
          for a b c
          using that(1) unfolding that(2,3) by simp

        show 
          "σNTMapb A𝔄 𝔊ArrMapf =
            ?the_cf_rKeArrMapf A𝔄 σNTMapa"
          if f_is_arr: "f : a  b" for a b f
        proof-

          note f = 𝔎.HomCod.cat_is_arrD[OF that]
          note lim_a = assms(3)[OF f(2)] and lim_b = assms(3)[OF f(3)]

          interpret lim_a: is_cat_limit 
            α a CF 𝔎 𝔄 𝔗 CF a OCF 𝔎 ?UObj a ?UArr a
            by (rule lim_a)
          interpret lim_b: is_cat_limit 
            α b CF 𝔎 𝔄 𝔗 CF b OCF 𝔎 ?UObj b ?UArr b
            by (rule lim_b)

          from f have a: "a  Obj" and b: "b  Obj" by auto
          
          from lim_b.cat_lim_unique_cone'[OF τ[OF that]] obtain g' 
            where g': "g' : 𝔊ObjMapa 𝔄 ?UObj b"
              and τ_NTMap_app: "A. A  (b CF 𝔎Obj) 
                τ a b fNTMapA = ?UArr bNTMapA A𝔄 g'"
              and g'_unique: "g''.
                
                  g'' : 𝔊ObjMapa 𝔄 ?UObj b;
                  A. A  b CF 𝔎Obj 
                    τ a b fNTMapA = ?UArr bNTMapA A𝔄 g''
                  g'' = g'"
            by metis

          have lim_Obj_a_f𝔎[symmetric, cat_Kan_cs_simps]:
            "?UArr aNTMapa', b', f' A f =
              ?UArr bNTMapA A𝔄 ?the_cf_rKeArrMapf"
            if "A = [a', b', f']" and "A  b CF 𝔎Obj" for A a' b' f'
          proof-
            from that(2) f_is_arr have a'_def: "a' = 0" 
              and b': "b'  𝔅Obj" 
              and f': "f' : b  𝔎ObjMapb'"
              unfolding that(1) by auto
            show ?thesis 
              unfolding that(1) 
              by 
                (
                  rule 
                    lim_Obj_the_cf_rKe_commute
                      [
                        where lim_Obj=lim_Obj, 
                        OF 
                          assms(1,2) 
                          lim_a 
                          lim_b 
                          f_is_arr 
                          that(2)[unfolded that(1)] 
                      ]
                )
          qed
          {
            fix a' b' f' A
            note 𝔗.HomCod.cat_assoc_helper[
              where h=?UArr bNTMapa',b',f' 
                and g=?the_cf_rKeArrMapf
                and q=?UArr aNTMapa', b', f' A f
                ]
          }
          note [cat_Kan_cs_simps] = this

          show ?thesis
          proof(rule trans_sym[where s=g'])
            show "σNTMapb A𝔄 𝔊ArrMapf = g'"
            proof(rule g'_unique)
              from that show
                "σNTMapb A𝔄 𝔊ArrMapf : 𝔊ObjMapa 𝔄 ?UObj b"
                by (cs_concl cs_intro: cat_cs_intros cat_Kan_cs_intros)
              fix A assume prems': "A  b CF 𝔎Obj"
              with f_is_arr obtain b' f' 
                where A_def: "A = [0, b', f']"
                  and b': "b'  𝔅Obj"
                  and f': "f' : b  𝔎ObjMapb'"
                by auto
              from f_is_arr prems' show
                "τ a b fNTMapA =
                  ?UArr bNTMapA A𝔄 (σNTMapb A𝔄 𝔊ArrMapf)"
                unfolding A_def
                by
                  (
                    cs_concl
                      cs_simp: cat_cs_simps cat_Kan_cs_simps
                      cs_intro: cat_cs_intros cat_Kan_cs_intros
                  )
            qed
            show "?the_cf_rKeArrMapf A𝔄 σNTMapa = g'"
            proof(rule g'_unique)                  
              fix A assume prems': "A  b CF 𝔎Obj"
              with f_is_arr obtain b' f' 
                where A_def: "A = [0, b', f']"
                  and b': "b'  𝔅Obj"
                  and f': "f' : b  𝔎ObjMapb'"
                by auto
              {
                fix a' b' f' A
                note 𝔗.HomCod.cat_assoc_helper
                  [
                    where h=?UArr bNTMapa', b', f' 
                      and g=σNTMapb
                      and q=εNTMapb' A𝔄 𝔊ArrMapf'
                  ]
              }
              note [cat_Kan_cs_simps] = 
                this
                εb_𝔊f[OF A_def prems' b, symmetric]
                εb_𝔊f[symmetric]
              from f_is_arr prems' b' f' show 
                "τ a b fNTMapA =
                  ?UArr bNTMapA A𝔄
                    (?the_cf_rKeArrMapf A𝔄 σNTMapa)"
                unfolding A_def
                by
                  (
                    cs_concl 
                      cs_simp: 
                        cat_cs_simps 
                        cat_Kan_cs_simps 
                        cat_comma_cs_simps
                        cat_op_simps
                      cs_intro: 
                        cat_cs_intros 
                        cat_Kan_cs_intros 
                        cat_comma_cs_intros 
                        cat_op_intros
                  )
            qed
              (
                use that in
                  cs_concl
                      cs_simp: cat_Kan_cs_simps
                      cs_intro: cat_cs_intros cat_Kan_cs_intros
              )
          qed
        qed
      qed
        (
          cs_concl
            cs_simp: cat_cs_simps cat_Kan_cs_simps
            cs_intro: cat_cs_intros
        )+
      then interpret σ: is_ntcf α  𝔄 𝔊 ?the_cf_rKe σ by simp

      show "ε = ?the_ntcf_rKe NTCF (σ NTCF-CF 𝔎)"
      proof(rule ntcf_eqI)
        have dom_lhs: "𝒟 (εNTMap) = 𝔅Obj" 
          by (cs_concl cs_simp: cat_cs_simps)
        have dom_rhs: "𝒟 ((?the_ntcf_rKe NTCF (σ NTCF-CF 𝔎))NTMap) = 𝔅Obj"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        show "εNTMap = (?the_ntcf_rKe NTCF (σ NTCF-CF 𝔎))NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix b assume prems': "b  𝔅Obj"
          note [cat_Kan_cs_simps] = εb_𝔊f[
            where f=CId𝔎ObjMapb and c=𝔎ObjMapb, symmetric
            ]
          from prems' σ show 
            "εNTMapb = (?the_ntcf_rKe NTCF (σ NTCF-CF 𝔎))NTMapb"
            by
              (
                cs_concl
                  cs_simp: cat_cs_simps cat_comma_cs_simps cat_Kan_cs_simps 
                  cs_intro: cat_cs_intros cat_comma_cs_intros cat_Kan_cs_intros
              )
        qed (cs_concl cs_intro: cat_cs_intros V_cs_intros)
      qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

      fix σ' assume prems':
        "σ' : 𝔊 CF ?the_cf_rKe :  ↦↦Cα 𝔄"
        "ε = ?the_ntcf_rKe NTCF (σ' NTCF-CF 𝔎)"

      interpret σ': is_ntcf α  𝔄 𝔊 ?the_cf_rKe σ' by (rule prems'(1))

      have ε_NTMap_app[symmetric, cat_Kan_cs_simps]: 
        "εNTMapb' =
          ?UArr (𝔎ObjMapb')NTMapa', b', CId𝔎ObjMapb' A𝔄
          σ'NTMap𝔎ObjMapb'"
        if "b'  𝔅Obj" and "a' = 0" for a' b'
      proof-
        from prems'(2) have ε_NTMap_app: 
          "εNTMapb' = (?the_ntcf_rKe NTCF (σ' NTCF-CF 𝔎))NTMapb'"
          for b'
          by simp
        show ?thesis
          using ε_NTMap_app[of b'] that(1)
          unfolding that(2)
          by
            (
              cs_prems
                cs_simp: cat_cs_simps cat_comma_cs_simps cat_Kan_cs_simps
                cs_intro: cat_cs_intros cat_comma_cs_intros
            )
      qed
      {
        fix a' b' f' A
        note 𝔗.HomCod.cat_assoc_helper
          [
            where h=
              ?UArr (𝔎ObjMapb')NTMapa', b', CId𝔎ObjMapb'
              and g=σ'NTMap𝔎ObjMapb'
              and q=εNTMapb'
          ]
      }
      note [cat_Kan_cs_simps] = this εb_𝔊f[symmetric]
      {
        fix a' b' f' A
        note 𝔗.HomCod.cat_assoc_helper
          [
            where h=?UArr (𝔎ObjMapb')NTMap
                a', b', CId𝔎ObjMapb'
                
            and g=σNTMap𝔎ObjMapb'
            and q=εNTMapb'
          ]
      }
      note [cat_Kan_cs_simps] = this

      show "σ' = σ"
      proof(rule ntcf_eqI)

        show "σ' : 𝔊 CF ?the_cf_rKe :  ↦↦Cα 𝔄" by (rule prems'(1))
        show "σ : 𝔊 CF ?the_cf_rKe :  ↦↦Cα 𝔄" by (rule σ)

        have dom_lhs: "𝒟 (σNTMap) = Obj" 
          by (cs_concl cs_simp: cat_cs_simps)
        have dom_rhs: "𝒟 (σ'NTMap) = Obj"
          by (cs_concl cs_simp: cat_cs_simps)

        show "σ'NTMap = σNTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)

          fix c assume prems': "c  Obj"

          note lim_c = assms(3)[OF prems']
          interpret lim_c: is_cat_limit 
            α c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ?UObj c ?UArr c
            by (rule lim_c)
          from prems' have CId_c: "CIdc : c  c"
            by (cs_concl cs_intro: cat_cs_intros)

          from lim_c.cat_lim_unique_cone'[OF τ[OF CId_c]] obtain f 
            where f: "f : 𝔊ObjMapc 𝔄 ?UObj c"
              and "A. A  c CF 𝔎Obj 
                τ c c (CIdc)NTMapA = ?UArr cNTMapA A𝔄 f"
              and f_unique: "f'.
                
                  f' : 𝔊ObjMapc 𝔄 ?UObj c;
                  A. A  c CF 𝔎Obj 
                    τ c c (CIdc)NTMapA = ?UArr cNTMapA A𝔄 f'
                  f' = f"
            by metis

          note [symmetric, cat_cs_simps] =
            σ.ntcf_Comp_commute
            σ'.ntcf_Comp_commute

          show "σ'NTMapc = σNTMapc"
          proof(rule trans_sym[where s=f])

            show "σ'NTMapc = f"
            proof(rule f_unique)

              fix A assume prems'': "A  c CF 𝔎Obj"

              with prems' obtain b' f' 
                where A_def: "A = [0, b', f']"
                  and b': "b'  𝔅Obj"
                  and f': "f' : c  𝔎ObjMapb'"
                by auto

              let ?𝔎b' = 𝔎ObjMapb'

              from b' have 𝔎b': "?𝔎b'  Obj"
                by (cs_concl cs_intro: cat_cs_intros)

              interpret lim_𝔎b': is_cat_limit
                α ?𝔎b' CF 𝔎 𝔄 𝔗 CF ?𝔎b' OCF 𝔎 ?UObj ?𝔎b' ?UArr ?𝔎b'
                by (rule assms(3)[OF 𝔎b'])

              from 𝔎b' have CId_𝔎b': "CId?𝔎b' : ?𝔎b'  ?𝔎b'"
                by (cs_concl cs_intro: cat_cs_intros)
              from CId_𝔎b' b' have a'_b'_CId_𝔎b':
                "[0, b', CId?𝔎b']  ?𝔎b' CF 𝔎Obj"
                by
                  (
                    cs_concl
                      cs_simp: cat_cs_simps cat_comma_cs_simps
                      cs_intro: cat_cs_intros cat_comma_cs_intros
                  )
              from 
                lim_Obj_the_cf_rKe_commute[
                  where lim_Obj=lim_Obj, 
                  OF assms(1,2) lim_c assms(3)[OF 𝔎b'] f' a'_b'_CId_𝔎b'
                  ]
                f'
              have [cat_Kan_cs_simps]:
                "?UArr cNTMap0, b', f' =
                  ?UArr ?𝔎b'NTMap0, b', CId?𝔎b' A𝔄 
                    ?the_cf_rKeArrMapf'"
                by (cs_prems cs_simp: cat_cs_simps)

              from prems' prems'' b' f' show
                "τ c c (CIdc)NTMapA = ?UArr cNTMapA A𝔄 σ'NTMapc"
                unfolding A_def (*very slow*)
                by
                  (
                    cs_concl
                      cs_simp:
                        cat_cs_simps cat_comma_cs_simps cat_Kan_cs_simps
                      cs_intro:
                        cat_cs_intros cat_comma_cs_intros cat_Kan_cs_intros
                  )

            qed
              (
                use prems' in
                  cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros
              )

            show "σNTMapc = f"
            proof(rule f_unique)
              fix A assume prems'': "A  c CF 𝔎Obj"
              from this prems' obtain b' f' 
                where A_def: "A = [0, b', f']"
                  and b': "b'  𝔅Obj"
                  and f': "f' : c  𝔎ObjMapb'"
                by auto
              let ?𝔎b' = 𝔎ObjMapb'
              from b' have 𝔎b': "?𝔎b'  Obj"
                by (cs_concl cs_intro: cat_cs_intros)
              interpret lim_𝔎b': is_cat_limit
                α ?𝔎b' CF 𝔎 𝔄 𝔗 CF ?𝔎b' OCF 𝔎 ?UObj ?𝔎b' ?UArr ?𝔎b'
                by (rule assms(3)[OF 𝔎b'])
              from 𝔎b' have CId_𝔎b': "CId?𝔎b' : ?𝔎b'  ?𝔎b'"
                by (cs_concl cs_intro: cat_cs_intros)
              from CId_𝔎b' b' have a'_b'_CId_𝔎b': 
                "[0, b', CId?𝔎b']  ?𝔎b' CF 𝔎Obj"
                by
                  (
                    cs_concl
                      cs_simp: cat_cs_simps cat_comma_cs_simps
                      cs_intro: cat_cs_intros cat_comma_cs_intros
                  )

              from 
                lim_Obj_the_cf_rKe_commute
                  [
                    where lim_Obj=lim_Obj, 
                    OF assms(1,2) lim_c assms(3)[OF 𝔎b'] f' a'_b'_CId_𝔎b'
                  ]
                f'
              have [cat_Kan_cs_simps]:
                "?UArr cNTMap0, b', f' =
                  ?UArr (?𝔎b')NTMap0, b', CId?𝔎b' A𝔄
                    ?the_cf_rKeArrMapf'"
                by (cs_prems cs_simp: cat_cs_simps)
              from prems' prems'' b' f' show
                "τ c c (CIdc)NTMapA = ?UArr cNTMapA A𝔄 σNTMapc"
                unfolding A_def (*very slow*)
                by
                  (
                    cs_concl
                      cs_simp:
                        cat_cs_simps cat_comma_cs_simps cat_Kan_cs_simps 
                      cs_intro:
                        cat_cs_intros cat_comma_cs_intros cat_Kan_cs_intros
                  )
            qed
              (
                use prems' in
                  cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros
              )
          qed

        qed auto

      qed simp_all

    qed

  qed (cs_concl cs_intro: cat_cs_intros)+

qed



subsection‹Preservation of Kan extension›


text‹
The following definitions are similar to the definitions that can be 
found in \cite{riehl_category_2016} or \cite{lehner_all_2014}.
›

locale is_cat_rKe_preserves =
  is_cat_rKe α 𝔅  𝔄 𝔎 𝔗 𝔊 ε + is_functor α 𝔄 𝔇 
  for α 𝔅  𝔄 𝔇 𝔎 𝔗 𝔊  ε +
  assumes cat_rKe_preserves:
    " CF-NTCF ε : ( CF 𝔊) CF 𝔎 CF.rKeα  CF 𝔗 : 𝔅 C  C 𝔇"

syntax "_is_cat_rKe_preserves" :: 
  "V  V  V  V  V  V  V  V  V  V  bool"
  (
    (_ :/ _ CF _ CF.rKeı _ :/ _ C _ C _ : _ ↦↦C _) 
    [51, 51, 51, 51, 51, 51, 51, 51, 51] 51
  )
translations "ε : 𝔊 CF 𝔎 CF.rKeα 𝔗 : 𝔅 C  C ( : 𝔄 ↦↦C 𝔇)"  
  "CONST is_cat_rKe_preserves α 𝔅  𝔄 𝔇 𝔎 𝔗 𝔊  ε"

locale is_cat_lKe_preserves =
  is_cat_lKe α 𝔅  𝔄 𝔎 𝔗 𝔉 η + is_functor α 𝔄 𝔇 
  for α 𝔅  𝔄 𝔇 𝔎 𝔗 𝔉  η +
  assumes cat_lKe_preserves:
    " CF-NTCF η :  CF 𝔗 CF.lKeα ( CF 𝔉) CF 𝔎 : 𝔅 C  C 𝔇"

syntax "_is_cat_lKe_preserves" :: 
  "V  V  V  V  V  V  V  V  V  V  bool"
  (
    (_ :/ _ CF.lKeı _ CF _ :/ _ C _ C _ : _ ↦↦C _) 
    [51, 51, 51, 51, 51, 51, 51, 51, 51] 51
  )
translations "η : 𝔗 CF.lKeα 𝔉 CF 𝔎 : 𝔅 C  C ( : 𝔄 ↦↦C 𝔇)" 
  "CONST is_cat_lKe_preserves α 𝔅  𝔄 𝔇 𝔎 𝔗 𝔉  η"


text‹Rules.›

lemma (in is_cat_rKe_preserves) is_cat_rKe_preserves_axioms':
  assumes "α' = α"
    and "𝔊' = 𝔊"
    and "𝔎' = 𝔎"
    and "𝔗' = 𝔗"
    and "ℌ' = "
    and "𝔅' = 𝔅"
    and "𝔄' = 𝔄"
    and "ℭ' = "
    and "𝔇' = 𝔇"
  shows "ε : 𝔊' CF 𝔎' CF.rKeα' 𝔗' : 𝔅' C ℭ' C (ℌ' : 𝔄' ↦↦C 𝔇')"
  unfolding assms by (rule is_cat_rKe_preserves_axioms)

mk_ide rf is_cat_rKe_preserves_def[unfolded is_cat_rKe_preserves_axioms_def]
  |intro is_cat_rKe_preservesI|
  |dest is_cat_rKe_preservesD[dest]|
  |elim is_cat_rKe_preservesE[elim]|

lemmas [cat_Kan_cs_intros] = is_cat_rKeD(1-3)

lemma (in is_cat_lKe_preserves) is_cat_lKe_preserves_axioms':
  assumes "α' = α"
    and "𝔉' = 𝔉"
    and "𝔎' = 𝔎"
    and "𝔗' = 𝔗"
    and "ℌ' = "
    and "𝔅' = 𝔅"
    and "𝔄' = 𝔄"
    and "ℭ' = "
    and "𝔇' = 𝔇"
  shows "η : 𝔗' CF.lKeα 𝔉' CF 𝔎' : 𝔅' C ℭ' C (ℌ' : 𝔄' ↦↦C 𝔇')"
  unfolding assms by (rule is_cat_lKe_preserves_axioms)

mk_ide rf is_cat_lKe_preserves_def[unfolded is_cat_lKe_preserves_axioms_def]
  |intro is_cat_lKe_preservesI|
  |dest is_cat_lKe_preservesD[dest]|
  |elim is_cat_lKe_preservesE[elim]|

lemmas [cat_Kan_cs_intros] = is_cat_lKe_preservesD(1-3)


text‹Duality.›

lemma (in is_cat_rKe_preserves) is_cat_rKe_preserves_op:
  "op_ntcf ε :
    op_cf 𝔗 CF.lKeα op_cf 𝔊 CF op_cf 𝔎 :
    op_cat 𝔅 C op_cat  C (op_cf  : op_cat 𝔄 ↦↦C op_cat 𝔇)"
proof(intro is_cat_lKe_preservesI)
  from cat_rKe_preserves show "op_cf  CF-NTCF op_ntcf ε :
    op_cf  CF op_cf 𝔗 CF.lKeα (op_cf  CF op_cf 𝔊) CF op_cf 𝔎 :
    op_cat 𝔅 C op_cat  C op_cat 𝔇"
    by (cs_concl_step op_ntcf_cf_ntcf_comp[symmetric])
      (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)
qed (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)+

lemma (in is_cat_rKe_preserves) is_cat_lKe_preserves_op'[cat_op_intros]:
  assumes "𝔗' = op_cf 𝔗"
    and "𝔊' = op_cf 𝔊"
    and "𝔎' = op_cf 𝔎"
    and "𝔅' = op_cat 𝔅"
    and "𝔄' = op_cat 𝔄"
    and "ℭ' = op_cat "
    and "𝔇' = op_cat 𝔇"
    and "ℌ' = op_cf "
  shows "op_ntcf ε :
    𝔗' CF.lKeα 𝔊' CF 𝔎' : 𝔅' C ℭ' C (ℌ' : 𝔄' ↦↦C 𝔇')"
  unfolding assms by (rule is_cat_rKe_preserves_op)

lemmas [cat_op_intros] = is_cat_rKe_preserves.is_cat_lKe_preserves_op'

lemma (in is_cat_lKe_preserves) is_cat_rKe_preserves_op:
  "op_ntcf η :
    op_cf 𝔉 CF op_cf 𝔎 CF.rKeα op_cf 𝔗 :
    op_cat 𝔅 C op_cat  C (op_cf  : op_cat 𝔄 ↦↦C op_cat 𝔇)"
proof(intro is_cat_rKe_preservesI)
  from cat_lKe_preserves show "op_cf  CF-NTCF op_ntcf η :
    (op_cf  CF op_cf 𝔉) CF op_cf 𝔎 CF.rKeα op_cf  CF op_cf 𝔗 :
    op_cat 𝔅 C op_cat  C op_cat 𝔇"
    by (cs_concl_step op_ntcf_cf_ntcf_comp[symmetric])
      (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)
qed (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)+

lemma (in is_cat_lKe_preserves) is_cat_rKe_preserves_op'[cat_op_intros]:
  assumes "𝔗' = op_cf 𝔗"
    and "𝔉' = op_cf 𝔉"
    and "𝔎' = op_cf 𝔎"
    and "ℌ' = op_cf "
    and "𝔅' = op_cat 𝔅"
    and "𝔄' = op_cat 𝔄"
    and "ℭ' = op_cat "
    and "𝔇' = op_cat 𝔇"
  shows "op_ntcf η :
    𝔉' CF 𝔎' CF.rKeα 𝔗' : 𝔅' C ℭ' C (ℌ' : 𝔄' ↦↦C 𝔇')"
  unfolding assms by (rule is_cat_rKe_preserves_op)



subsection‹All concepts are Kan extensions›


text‹
Background information for this subsection is provided in 
Chapter X-7 in \cite{mac_lane_categories_2010}
and section 6.5 in \cite{riehl_category_2016}. 
It should be noted that only the connections between the Kan extensions,
limits and adjunctions are exposed (an alternative proof of the Yoneda
lemma using Kan extensions is not provided in the context of this work).
›


subsubsection‹Limits›

lemma cat_rKe_is_cat_limit:
  ―‹The statement of the theorem is similar to the statement of a part of
    Theorem 1 in Chapter X-7 in \cite{mac_lane_categories_2010}
    or Proposition 6.5.1 in \cite{riehl_category_2016}.›
  assumes "ε : 𝔊 CF 𝔎 CF.rKeα 𝔗 : 𝔅 C cat_1 𝔞 𝔣 C 𝔄"
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
  shows "ε : 𝔊ObjMap𝔞 <CF.lim 𝔗 : 𝔅 ↦↦Cα 𝔄"
proof-

  interpret ε: is_cat_rKe α 𝔅 ‹cat_1 𝔞 𝔣 𝔄 𝔎 𝔗 𝔊 ε by (rule assms(1))  
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  
  from cat_1_components(1) have 𝔞: "𝔞  Vset α" 
    by (auto simp: ε.AG.HomCod.cat_in_Obj_in_Vset)
  from cat_1_components(2) have 𝔣: "𝔣  Vset α" 
    by (auto simp: ε.AG.HomCod.cat_in_Arr_in_Vset)

  have 𝔎_def: "𝔎 = cf_const 𝔅 (cat_1 𝔞 𝔣) 𝔞"
    by (rule cf_const_if_HomCod_is_cat_1) 
      (cs_concl cs_intro: cat_cs_intros)
  have 𝔊𝔎_def: "𝔊 CF 𝔎 = cf_const 𝔅 𝔄 (𝔊ObjMap𝔞)"
    by
      (
        cs_concl
          cs_simp: cat_1_components(1) 𝔎_def cat_cs_simps 
          cs_intro: V_cs_intros cat_cs_intros
      )

  interpret ε: is_tm_ntcf α 𝔅 𝔄 𝔊 CF 𝔎 𝔗 ε 
    by 
      (
        intro is_tm_ntcfI' assms(2) ε.ntcf_rKe.is_ntcf_axioms, 
        unfold 𝔊𝔎_def
      )
      (
        cs_concl 
          cs_simp: cat_cs_simps cs_intro: cat_small_cs_intros cat_cs_intros
      )

  show "ε : 𝔊ObjMap𝔞 <CF.lim 𝔗 : 𝔅 ↦↦Cα 𝔄"
  proof(intro is_cat_limitI' is_cat_coneI)

    show "ε : cf_const 𝔅 𝔄 (𝔊ObjMap𝔞) CF.tm 𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    proof(intro is_tm_ntcfI' ε.ntcf_rKe.is_ntcf_axioms[unfolded 𝔊𝔎_def])
      from assms(2) show "cf_const 𝔅 𝔄 (𝔊ObjMap𝔞) : 𝔅 ↦↦C.tmα 𝔄"
        by (cs_concl cs_intro: cat_small_cs_intros cat_cs_intros)
    qed (rule assms(2))

    fix u' r' assume prems: "u' : r' <CF.cone 𝔗 : 𝔅 ↦↦Cα 𝔄"

    interpret u': is_cat_cone α r' 𝔅 𝔄 𝔗 u' by (rule prems)

    have 𝔊_def: "𝔊 = cf_const (cat_1 𝔞 𝔣) 𝔄 (𝔊ObjMap𝔞)"
      by (rule cf_const_if_HomDom_is_cat_1[OF ε.Ran.is_functor_axioms])

    from prems have const_r': "cf_const (cat_1 𝔞 𝔣) 𝔄 r' : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
      by 
        (
          cs_concl
            cs_simp: cat_cs_simps cs_intro: cat_lim_cs_intros cat_cs_intros
        )

    have cf_comp_cf_const_r_𝔎_def: 
      "cf_const (cat_1 𝔞 𝔣) 𝔄 r' CF 𝔎 = cf_const 𝔅 𝔄 r'"
      by 
        (
          cs_concl
            cs_simp: cat_cs_simps 𝔎_def
            cs_intro: cat_cs_intros cat_lim_cs_intros
        )

    from ε.cat_rKe_unique[
        OF const_r', unfolded cf_comp_cf_const_r_𝔎_def, OF u'.is_ntcf_axioms
        ] 
    obtain σ 
      where σ: "σ : cf_const (cat_1 𝔞 𝔣) 𝔄 r' CF 𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
        and u'_def: "u' = ε NTCF (σ NTCF-CF 𝔎)"
        and unique_σ: "σ'.
          
            σ' : cf_const (cat_1 𝔞 𝔣) 𝔄 r' CF 𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄;
            u' = ε NTCF (σ' NTCF-CF 𝔎)
            σ' = σ"
      by auto

    interpret σ: is_ntcf α ‹cat_1 𝔞 𝔣 𝔄 ‹cf_const (cat_1 𝔞 𝔣) 𝔄 r' 𝔊 σ
      by (rule σ)
    
    show "∃!f'. f' : r' 𝔄 𝔊ObjMap𝔞  u' = ε NTCF ntcf_const 𝔅 𝔄 f'"
    proof(intro ex1I conjI; (elim conjE)?)
      fix f' assume prems': 
        "f' : r' 𝔄 𝔊ObjMap𝔞" "u' = ε NTCF ntcf_const 𝔅 𝔄 f'"
      from prems'(1) have "ntcf_const (cat_1 𝔞 𝔣) 𝔄 f' :
        cf_const (cat_1 𝔞 𝔣) 𝔄 r' CF 𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
        by (subst 𝔊_def) 
          (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      moreover then have "u' = ε NTCF (ntcf_const (cat_1 𝔞 𝔣) 𝔄 f' NTCF-CF 𝔎)"
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps prems'(2) 𝔎_def cs_intro: cat_cs_intros
          )
      ultimately have σ_def: "σ = ntcf_const (cat_1 𝔞 𝔣) 𝔄 f'"
        by (auto simp: unique_σ[symmetric])
      show "f' = σNTMap𝔞"
        by (cs_concl cs_simp: cat_cs_simps σ_def cs_intro: cat_cs_intros)
    qed (cs_concl cs_simp: cat_cs_simps u'_def 𝔎_def cs_intro: cat_cs_intros)+

  qed (cs_concl cs_simp: 𝔎_def cs_intro: cat_cs_intros)

qed

lemma cat_lKe_is_cat_colimit:
  assumes "η : 𝔗 CF.lKeα 𝔉 CF 𝔎 : 𝔅 C cat_1 𝔞 𝔣 C 𝔄"
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
  shows "η : 𝔗 >CF.colim 𝔉ObjMap𝔞 : 𝔅 ↦↦Cα 𝔄"
proof-
  interpret η: is_cat_lKe α 𝔅 ‹cat_1 𝔞 𝔣 𝔄 𝔎 𝔗 𝔉 η by (rule assms(1))  
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  from cat_1_components(1) have 𝔞: "𝔞  Vset α" 
    by (auto simp: η.AG.HomCod.cat_in_Obj_in_Vset)
  from cat_1_components(2) have 𝔣: "𝔣  Vset α" 
    by (auto simp: η.AG.HomCod.cat_in_Arr_in_Vset)
  show ?thesis
    by 
      (
        rule is_cat_limit.is_cat_colimit_op
          [
            OF cat_rKe_is_cat_limit[
              OF η.is_cat_rKe_op[unfolded η.AG.cat_1_op[OF 𝔞 𝔣]] 
              𝔗.is_tm_functor_op
              ], 
            unfolded cat_op_simps
          ]
      )
qed

lemma cat_limit_is_rKe:
  ―‹The statement of the theorem is similar to the statement of a part of
    Theorem 1 in Chapter X-7 in \cite{mac_lane_categories_2010} 
    or Proposition 6.5.1 in \cite{riehl_category_2016}.›
  assumes "ε : 𝔊ObjMap𝔞 <CF.lim 𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "𝔎 : 𝔅 ↦↦Cα cat_1 𝔞 𝔣"
    and "𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
  shows "ε : 𝔊 CF 𝔎 CF.rKeα 𝔗 : 𝔅 C cat_1 𝔞 𝔣 C 𝔄"
proof-

  interpret ε: is_cat_limit α 𝔅 𝔄 𝔗 𝔊ObjMap𝔞 ε by (rule assms)
  interpret 𝔎: is_functor α 𝔅 ‹cat_1 𝔞 𝔣 𝔎 by (rule assms(2))
  interpret 𝔊: is_functor α ‹cat_1 𝔞 𝔣 𝔄 𝔊 by (rule assms(3))

  show ?thesis
  proof(rule is_cat_rKeI')

    note 𝔎_def = cf_const_if_HomCod_is_cat_1[OF assms(2)]
    note 𝔊_def = cf_const_if_HomDom_is_cat_1[OF assms(3)]

    have 𝔊𝔎_def: "𝔊 CF 𝔎 = cf_const 𝔅 𝔄 (𝔊ObjMap𝔞)"
      by (subst 𝔎_def, use nothing in subst 𝔊_def›)
        (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

    show "ε : 𝔊 CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄" 
      by (cs_concl cs_simp: cat_cs_simps 𝔊𝔎_def cs_intro: cat_cs_intros)
    fix 𝔊' ε' assume prems: 
      "𝔊' : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
      "ε' : 𝔊' CF 𝔎 CF 𝔗 : 𝔅 ↦↦Cα 𝔄"

    interpret is_functor α ‹cat_1 𝔞 𝔣 𝔄 𝔊' by (rule prems(1))
  
    note 𝔊'_def = cf_const_if_HomDom_is_cat_1[OF prems(1)]

    from prems(2) have ε': 
      "ε' : cf_const 𝔅 𝔄 (𝔊'ObjMap𝔞) CF 𝔗 : 𝔅 ↦↦Cα 𝔄"
      unfolding 𝔎_def 
      by (subst (asm) 𝔊'_def)
        (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from prems(2) have "ε' : 𝔊'ObjMap𝔞 <CF.cone 𝔗 : 𝔅 ↦↦Cα 𝔄"
      by (intro is_cat_coneI is_tm_ntcfI' ε')
        (cs_concl cs_intro: cat_small_cs_intros cat_cs_intros)+

    from ε.cat_lim_unique_cone[OF this] obtain f'
      where f': "f' : 𝔊'ObjMap𝔞 𝔄 𝔊ObjMap𝔞"
        and ε_def: "ε' = ε NTCF ntcf_const 𝔅 𝔄 f'"
        and unique_f':
          "
            f'' : 𝔊'ObjMap𝔞 𝔄 𝔊ObjMap𝔞;
            ε' = ε NTCF ntcf_const 𝔅 𝔄 f''
            f'' = f'"
        for f''
      by metis

    show "∃!σ.
      σ : 𝔊' CF 𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄  ε' = ε NTCF (σ NTCF-CF 𝔎)"
    proof(intro ex1I conjI; (elim conjE)?)  
      from f' show 
        "ntcf_const (cat_1 𝔞 𝔣) 𝔄 f' : 𝔊' CF 𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
        by (subst 𝔊'_def, use nothing in subst 𝔊_def›) 
          (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      then show "ε' = ε NTCF (ntcf_const (cat_1 𝔞 𝔣) 𝔄 f' NTCF-CF 𝔎)"
        by (cs_concl cs_simp: cat_cs_simps ε_def 𝔎_def cs_intro: cat_cs_intros)
      fix σ assume prems:
        "σ : 𝔊' CF 𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
        "ε' = ε NTCF (σ NTCF-CF 𝔎)"
      interpret σ: is_ntcf α ‹cat_1 𝔞 𝔣 𝔄 𝔊' 𝔊 σ by (rule prems(1))
      have "σNTMap𝔞 : 𝔊'ObjMap𝔞 𝔄 𝔊ObjMap𝔞"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      moreover have "ε' = ε NTCF ntcf_const 𝔅 𝔄 (σNTMap𝔞)"
        by
          (
            cs_concl
              cs_simp: cat_cs_simps prems(2) 𝔎_def cs_intro: cat_cs_intros
          )
      ultimately have σ𝔞: "σNTMap𝔞 = f'" by (rule unique_f')
      show "σ = ntcf_const (cat_1 𝔞 𝔣) 𝔄 f'"
      proof(rule ntcf_eqI)
        from f' show 
          "ntcf_const (cat_1 𝔞 𝔣) 𝔄 f' : 𝔊' CF 𝔊 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
          by (subst 𝔊'_def, use nothing in subst 𝔊_def›)
            (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        have dom_lhs: "𝒟 (σNTMap) = cat_1 𝔞 𝔣Obj"
          by (cs_concl cs_simp: cat_cs_simps cs_intro:cat_cs_intros)
        have dom_rhs: "𝒟 (ntcf_const (cat_1 𝔞 𝔣) 𝔄 f'NTMap) = cat_1 𝔞 𝔣Obj"
          by (cs_concl cs_simp: cat_cs_simps cs_intro:cat_cs_intros)
        show "σNTMap = ntcf_const (cat_1 𝔞 𝔣) 𝔄 f'NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix a assume prems: "a  cat_1 𝔞 𝔣Obj"
          then have a_def: "a = 𝔞" unfolding cat_1_components by simp
          from f' show "σNTMapa = ntcf_const (cat_1 𝔞 𝔣) 𝔄 f'NTMapa"
            unfolding a_def σ𝔞
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        qed (auto intro: cat_cs_intros)
      qed (simp_all add: prems)
    qed
  qed (auto simp: assms)

qed

lemma cat_colimit_is_lKe:
  assumes "η : 𝔗 >CF.colim 𝔉ObjMap𝔞 : 𝔅 ↦↦Cα 𝔄"
    and "𝔎 : 𝔅 ↦↦Cα cat_1 𝔞 𝔣"
    and "𝔉 : cat_1 𝔞 𝔣 ↦↦Cα 𝔄"
  shows "η : 𝔗 CF.lKeα 𝔉 CF 𝔎 : 𝔅 C cat_1 𝔞 𝔣 C 𝔄"
proof-
  interpret η: is_cat_colimit α 𝔅 𝔄 𝔗 𝔉ObjMap𝔞 η
    by (rule assms(1))
  interpret 𝔎: is_functor α 𝔅 ‹cat_1 𝔞 𝔣 𝔎 by (rule assms(2))
  interpret 𝔉: is_functor α ‹cat_1 𝔞 𝔣 𝔄 𝔉 by (rule assms(3))
  from cat_1_components(1) have 𝔞: "𝔞  Vset α"
    by (auto simp: 𝔎.HomCod.cat_in_Obj_in_Vset)
  from cat_1_components(2) have 𝔣: "𝔣  Vset α" 
    by (auto simp: 𝔎.HomCod.cat_in_Arr_in_Vset)
  have 𝔉𝔞: "𝔉ObjMap𝔞 = op_cf 𝔉ObjMap𝔞" unfolding cat_op_simps by simp
  note cat_1_op = η.cat_1_op[OF 𝔞 𝔣]
  show ?thesis
    by 
      (
        rule is_cat_rKe.is_cat_lKe_op
          [
            OF cat_limit_is_rKe
              [
                OF 
                  η.is_cat_limit_op[unfolded 𝔉𝔞]
                  𝔎.is_functor_op[unfolded cat_1_op]
                  𝔉.is_functor_op[unfolded cat_1_op]
              ],
            unfolded cat_op_simps cat_1_op
          ]
      )
qed


subsubsection‹Adjoints›

lemma (in is_cf_adjunction) cf_adjunction_counit_is_rKe:
  ―‹The statement of the theorem is similar to the statement of a part of
    Theorem 2 in Chapter X-7 in \cite{mac_lane_categories_2010}
    or Proposition 6.5.2 in \cite{riehl_category_2016}.
    The proof follows (approximately) the proof in \cite{riehl_category_2016}.›
  shows "εC Φ : 𝔉 CF 𝔊 CF.rKeα cf_id 𝔇 : 𝔇 C  C 𝔇"
proof-

  define β where "β = α + ω"
  have β: "𝒵 β" and αβ: "α  β" 
    by (simp_all add: β_def 𝒵_Limit_αω 𝒵_ω_αω 𝒵_def 𝒵_α_αω)
  then interpret β: 𝒵 β by simp

  note exp_adj = cf_adj_exp_cf_cat_exp_cf_cat[OF β αβ R.category_axioms]

  let  = ηC Φ
  let  = εC Φ
  let ?𝔇η = ‹exp_cat_ntcf α 𝔇 
  let ?𝔇𝔉 = ‹exp_cat_cf α 𝔇 𝔉
  let ?𝔇𝔊 = ‹exp_cat_cf α 𝔇 𝔊
  let ?𝔇𝔇 = ‹cat_FUNCT α 𝔇 𝔇
  let ?ℭ𝔇 = ‹cat_FUNCT α  𝔇
  let ?adj_𝔇η = ‹cf_adjunction_of_unit β ?𝔇𝔊 ?𝔇𝔉 ?𝔇η

  interpret 𝔇η: is_cf_adjunction β ?ℭ𝔇 ?𝔇𝔇 ?𝔇𝔊 ?𝔇𝔉 ?adj_𝔇η by (rule exp_adj)

  show ?thesis
  proof(intro is_cat_rKeI)
    have id_𝔇: "cf_map (cf_id 𝔇)  cat_FUNCT α 𝔇 𝔇Obj"
      by 
        (
          cs_concl
            cs_simp: cat_FUNCT_components(1)
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros
        )
    then have exp_id_𝔇: 
      "exp_cat_cf α 𝔇 𝔉ObjMapcf_map (cf_id 𝔇) = cf_map 𝔉"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps cs_intro: cat_cs_intros
        )
    have 𝔉: "cf_map 𝔉  cat_FUNCT α  𝔇Obj"
      by 
        (
          cs_concl 
            cs_simp: cat_FUNCT_components(1)
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros
        )
    have ε: "ntcf_arrow (εC Φ)  ntcf_arrows α 𝔇 𝔇"
      by (cs_concl cs_intro: cat_FUNCT_cs_intros adj_cs_intros)
    have 𝔇𝔇: "category β (cat_FUNCT α 𝔇 𝔇)"
      by (cs_concl cs_intro: cat_cs_intros)
    have ℭ𝔇: "category β (cat_FUNCT α  𝔇)"
      by (cs_concl cs_intro: cat_cs_intros)

    from 
      ε 𝔉 αβ id_𝔇 
      𝔇𝔇 ℭ𝔇 LR.is_functor_axioms RL.is_functor_axioms R.cat_cf_id_is_functor
      NT.is_iso_ntcf_axioms 
    have ε_id_𝔇: "εC ?adj_𝔇ηNTMapcf_map (cf_id 𝔇) = ntcf_arrow "
      by
        (
          cs_concl
            cs_simp:
              cat_Set_the_inverse[symmetric]
              cat_op_simps
              cat_cs_simps
              cat_FUNCT_cs_simps
              adj_cs_simps 
            cs_intro:
              𝔇η.NT.iso_ntcf_is_arr_isomorphism''
              cat_op_intros
              adj_cs_intros
              cat_small_cs_intros
              cat_cs_intros
              cat_FUNCT_cs_intros
              cat_prod_cs_intros
        )      
   show "universal_arrow_fo ?𝔇𝔊 (cf_map (cf_id 𝔇)) (cf_map 𝔉) (ntcf_arrow )"
      by 
        (
          rule is_cf_adjunction.cf_adjunction_counit_component_is_ua_fo[
            OF exp_adj id_𝔇, unfolded exp_id_𝔇 ε_id_𝔇
            ]
        )
  qed (cs_concl cs_intro: cat_cs_intros adj_cs_intros)+

qed

lemma (in is_cf_adjunction) cf_adjunction_unit_is_lKe:
  shows "ηC Φ : cf_id  CF.lKeα 𝔊 CF 𝔉 :  C 𝔇 C "
  by 
    (
      rule is_cat_rKe.is_cat_lKe_op
        [
          OF is_cf_adjunction.cf_adjunction_counit_is_rKe
            [
              OF is_cf_adjunction_op,
              folded op_ntcf_cf_adjunction_unit op_cf_cf_id
            ],
          unfolded 
            cat_op_simps ntcf_op_ntcf_op_ntcf[OF cf_adjunction_unit_is_ntcf]
        ]
    )

lemma cf_adjunction_if_lKe_preserves:
  ―‹The statement of the theorem is similar to the statement of a part of
    Theorem 2 in Chapter X-7 in \cite{mac_lane_categories_2010}
    or Proposition 6.5.2 in \cite{riehl_category_2016}.›
  assumes "η : cf_id 𝔇 CF.lKeα 𝔉 CF 𝔊 : 𝔇 C  C (𝔊 : 𝔇 ↦↦C )"
  shows "cf_adjunction_of_unit α 𝔊 𝔉 η : 𝔊 CF 𝔉 : 𝔇 ⇌⇌Cα "
proof-

  interpret η: is_cat_lKe_preserves α 𝔇  𝔇  𝔊 ‹cf_id 𝔇 𝔉 𝔊 η 
    by (rule assms)

  from η.cat_lKe_preserves interpret 𝔊η:
    is_cat_lKe α 𝔇   𝔊 𝔊 𝔊 CF 𝔉 𝔊 CF-NTCF η
    by (cs_prems cs_simp: cat_cs_simps)

  from 
    𝔊η.cat_lKe_unique
      [
        OF η.AG.HomCod.cat_cf_id_is_functor,
        unfolded η.AG.cf_cf_comp_cf_id_left,
        OF η.AG.cf_ntcf_id_is_ntcf
      ]
  obtain ε where ε: "ε : 𝔊 CF 𝔉 CF cf_id  :  ↦↦Cα "
    and ntcf_id_𝔊_def: "ntcf_id 𝔊 = ε NTCF-CF 𝔊 NTCF (𝔊 CF-NTCF η)"
    by metis
  interpret ε: is_ntcf α   𝔊 CF 𝔉 ‹cf_id  ε by (rule ε)
  
  show ?thesis
  proof(rule counit_unit_is_cf_adjunction)

    show [cat_cs_simps]: "ε NTCF-CF 𝔊 NTCF (𝔊 CF-NTCF η) = ntcf_id 𝔊"
      by (rule ntcf_id_𝔊_def[symmetric])

    have η_def: "η = (ntcf_id 𝔉 NTCF-CF 𝔊) NTCF η"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps ntcf_id_cf_comp[symmetric] 
            cs_intro: cat_cs_intros
        )
    note [cat_cs_simps] = this[symmetric]

    let ?𝔉ε𝔊 = 𝔉 CF-NTCF ε NTCF-CF 𝔊
    let ?η𝔉𝔊 = η NTCF-CF 𝔉 NTCF-CF 𝔊
    let ?𝔉𝔊η = 𝔉 CF 𝔊 CF-NTCF η

    have "(?𝔉ε𝔊 NTCF ?η𝔉𝔊) NTCF η = (?𝔉ε𝔊 NTCF ?𝔉𝔊η) NTCF η"
    proof(rule ntcf_eqI)
      have dom_lhs: "𝒟 (((?𝔉ε𝔊 NTCF ?η𝔉𝔊) NTCF η)NTMap) = 𝔇Obj"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      have dom_rhs: "𝒟 (((?𝔉ε𝔊 NTCF ?𝔉𝔊η) NTCF η)NTMap) = 𝔇Obj"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      note is_ntcf.ntcf_Comp_commute[cat_cs_simps del]
      note category.cat_Comp_assoc[cat_cs_simps del]
      show
        "((?𝔉ε𝔊 NTCF ?η𝔉𝔊) NTCF η)NTMap =
          ((?𝔉ε𝔊 NTCF ?𝔉𝔊η) NTCF η)NTMap"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
        fix a assume "a  𝔇Obj"
        then show
          "((?𝔉ε𝔊 NTCF ?η𝔉𝔊) NTCF η)NTMapa =
            ((?𝔉ε𝔊 NTCF ?𝔉𝔊η) NTCF η)NTMapa"
          by
            (
              cs_concl 
                cs_simp: cat_cs_simps η.ntcf_lKe.ntcf_Comp_commute[symmetric]
                cs_intro: cat_cs_intros
            )
      qed (cs_concl cs_intro: cat_cs_intros)+
    qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+
    also have " = (ntcf_id 𝔉 NTCF-CF 𝔊) NTCF η"
      by
        (
          cs_concl
            cs_simp:
              cat_cs_simps
              cf_comp_cf_ntcf_comp_assoc
              cf_ntcf_comp_ntcf_cf_comp_assoc
              cf_ntcf_comp_ntcf_vcomp[symmetric]
            cs_intro: cat_cs_intros
        )
    also have " = η" by (cs_concl cs_simp: cat_cs_simps)
    finally have "(?𝔉ε𝔊 NTCF ?η𝔉𝔊) NTCF η = η" by simp
    then have η_def':
      "η = (𝔉 CF-NTCF ε NTCF (η NTCF-CF 𝔉) NTCF-CF 𝔊) NTCF η"
      by 
        (
          cs_concl
            cs_simp: cat_cs_simps ntcf_vcomp_ntcf_cf_comp[symmetric] 
            cs_intro: cat_cs_intros
        )+
  
    have 𝔉εη𝔉:
      "𝔉 CF-NTCF ε NTCF (η NTCF-CF 𝔉) : 𝔉 CF 𝔉 :  ↦↦Cα 𝔇"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

    from η.cat_lKe_unique[OF η.Lan.is_functor_axioms η.ntcf_lKe.is_ntcf_axioms]
    obtain σ where
      " σ' : 𝔉 CF 𝔉 :  ↦↦Cα 𝔇; η = σ' NTCF-CF 𝔊 NTCF η   
        σ' = σ"
      for σ'
      by metis
  
    from this[OF η.Lan.cf_ntcf_id_is_ntcf η_def] this[OF 𝔉εη𝔉 η_def'] show
      "𝔉 CF-NTCF ε NTCF (η NTCF-CF 𝔉) = ntcf_id 𝔉"
      by simp

  qed (cs_concl cs_intro: cat_cs_intros)+

qed

lemma cf_adjunction_if_rKe_preserves:
  assumes "ε : 𝔉 CF 𝔊 CF.rKeα cf_id 𝔇 : 𝔇 C  C (𝔊 : 𝔇 ↦↦C )"
  shows "cf_adjunction_of_counit α 𝔉 𝔊 ε : 𝔉 CF 𝔊 :  ⇌⇌Cα 𝔇"
proof-
  interpret ε: is_cat_rKe_preserves α 𝔇  𝔇  𝔊 ‹cf_id 𝔇 𝔉 𝔊 ε 
    by (rule assms)
  have "op_cf (cf_id 𝔇) = cf_id (op_cat 𝔇)" unfolding cat_op_simps by simp
  show ?thesis
    by 
      (
        rule is_cf_adjunction.is_cf_adjunction_op
          [
            OF cf_adjunction_if_lKe_preserves[
              OF ε.is_cat_rKe_preserves_op[unfolded op_cf_cf_id]
              ], 
            folded cf_adjunction_of_counit_def, 
            unfolded cat_op_simps
          ]
      )
qed

text‹\newpage›

end

Theory CZH_UCAT_PWKan

(* Copyright 2021 (C) Mihails Milehins *)

section‹Pointwise Kan extensions›
theory CZH_UCAT_PWKan
  imports CZH_UCAT_Kan
begin



subsection‹Pointwise Kan extensions›


text‹
The following subsection is based on elements of the
content of section 6.3 in \cite{riehl_category_2016} and
Chapter X-5 in \cite{mac_lane_categories_2010}.
›

locale is_cat_pw_rKe = is_cat_rKe α 𝔅  𝔄 𝔎 𝔗 𝔊 ε
  for α 𝔅  𝔄 𝔎 𝔗 𝔊 ε +
  assumes cat_pw_rKe_preserved: "a  𝔄Obj 
    ε :
      𝔊 CF 𝔎 CF.rKeα 𝔗 :
      𝔅 C  C (HomO.Cα𝔄(a,-) : 𝔄 ↦↦C cat_Set α)"

syntax "_is_cat_pw_rKe" :: "V  V  V  V  V  V  V  V  bool"
  (
    (_ :/ _ CF _ CF.rKe.pwı _ :/ _ C _ C _) 
    [51, 51, 51, 51, 51, 51, 51] 51
  )
translations "ε : 𝔊 CF 𝔎 CF.rKe.pwα 𝔗 : 𝔅 C  C 𝔄"  
  "CONST is_cat_pw_rKe α 𝔅  𝔄 𝔎 𝔗 𝔊 ε"

locale is_cat_pw_lKe = is_cat_lKe α 𝔅  𝔄 𝔎 𝔗 𝔉 η
  for α 𝔅  𝔄 𝔎 𝔗 𝔉 η +
  assumes cat_pw_lKe_preserved: "a  op_cat 𝔄Obj 
    op_ntcf η :
      op_cf 𝔉 CF op_cf 𝔎 CF.rKeα op_cf 𝔗 :
      op_cat 𝔅 C op_cat  C (HomO.Cα𝔄(-,a) : op_cat 𝔄 ↦↦C cat_Set α)"

syntax "_is_cat_pw_lKe" :: "V  V  V  V  V  V  V  V  bool"
  (
    (_ :/ _ CF.lKe.pwı _ CF _ :/ _ C _ C _) 
    [51, 51, 51, 51, 51, 51, 51] 51
  )
translations "η : 𝔗 CF.lKe.pwα 𝔉 CF 𝔎 : 𝔅 C  C 𝔄"  
  "CONST is_cat_pw_lKe α 𝔅  𝔄 𝔎 𝔗 𝔉 η"

lemma (in is_cat_pw_rKe) cat_pw_rKe_preserved'[cat_Kan_cs_intros]: 
  assumes "a  𝔄Obj"
    and "𝔄' = 𝔄"
    and "ℌ' = HomO.Cα𝔄(a,-)"
    and "𝔈' = cat_Set α"
  shows "ε : 𝔊 CF 𝔎 CF.rKeα 𝔗 : 𝔅 C  C (ℌ' : 𝔄' ↦↦C 𝔈')"
  using assms(1) unfolding assms(2-4) by (rule cat_pw_rKe_preserved)

lemmas [cat_Kan_cs_intros] = is_cat_pw_rKe.cat_pw_rKe_preserved'

lemma (in is_cat_pw_lKe) cat_pw_lKe_preserved'[cat_Kan_cs_intros]: 
  assumes "a  op_cat 𝔄Obj"
    and "𝔉' = op_cf 𝔉"
    and "𝔎' = op_cf 𝔎"
    and "𝔗' = op_cf 𝔗"
    and "𝔅' = op_cat 𝔅"
    and "ℭ' = op_cat "
    and "𝔄' = op_cat 𝔄"
    and "ℌ' = HomO.Cα𝔄(-,a)"
    and "𝔈' = cat_Set α"
  shows "op_ntcf η :
    𝔉' CF 𝔎' CF.rKeα 𝔗' : 𝔅' C ℭ' C (ℌ' : 𝔄' ↦↦C 𝔈')"
  using assms(1) unfolding assms by (rule cat_pw_lKe_preserved)

lemmas [cat_Kan_cs_intros] = is_cat_pw_lKe.cat_pw_lKe_preserved'


text‹Rules.›

lemma (in is_cat_pw_rKe) is_cat_pw_rKe_axioms'[cat_Kan_cs_intros]:
  assumes "α' = α"
    and "𝔊' = 𝔊"
    and "𝔎' = 𝔎"
    and "𝔗' = 𝔗"
    and "𝔅' = 𝔅"
    and "𝔄' = 𝔄"
    and "ℭ' = "
  shows "ε : 𝔊' CF 𝔎' CF.rKe.pwα' 𝔗' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_pw_rKe_axioms)

mk_ide rf is_cat_pw_rKe_def[unfolded is_cat_pw_rKe_axioms_def]
  |intro is_cat_pw_rKeI|
  |dest is_cat_pw_rKeD[dest]|
  |elim is_cat_pw_rKeE[elim]|

lemmas [cat_Kan_cs_intros] = is_cat_pw_rKeD(1)

lemma (in is_cat_pw_lKe) is_cat_pw_lKe_axioms'[cat_Kan_cs_intros]:
  assumes "α' = α"
    and "𝔉' = 𝔉"
    and "𝔎' = 𝔎"
    and "𝔗' = 𝔗"
    and "𝔅' = 𝔅"
    and "𝔄' = 𝔄"
    and "ℭ' = "
  shows "η : 𝔗' CF.lKe.pwα' 𝔉' CF 𝔎' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_pw_lKe_axioms)

mk_ide rf is_cat_pw_lKe_def[unfolded is_cat_pw_lKe_axioms_def]
  |intro is_cat_pw_lKeI|
  |dest is_cat_pw_lKeD[dest]|
  |elim is_cat_pw_lKeE[elim]|

lemmas [cat_Kan_cs_intros] = is_cat_pw_lKeD(1)


text‹Duality.›

lemma (in is_cat_pw_rKe) is_cat_pw_lKe_op:
  "op_ntcf ε :
    op_cf 𝔗 CF.lKe.pwα op_cf 𝔊 CF op_cf 𝔎 :
    op_cat 𝔅 C op_cat  C op_cat 𝔄"
proof(intro is_cat_pw_lKeI, unfold cat_op_simps)
  fix a assume prems: "a  𝔄Obj"
  from cat_pw_rKe_preserved[OF prems] prems show
    "ε :
      𝔊 CF 𝔎 CF.rKeα 𝔗 :
      𝔅 C  C (HomO.Cαop_cat 𝔄(-,a) : 𝔄 ↦↦C cat_Set α)"
    by (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros)    
qed (cs_concl cs_intro: cat_op_intros)

lemma (in is_cat_pw_rKe) is_cat_pw_lKe_op'[cat_op_intros]:
  assumes "𝔗' = op_cf 𝔗"
    and "𝔊' = op_cf 𝔊"
    and "𝔎' = op_cf 𝔎"
    and "𝔅' = op_cat 𝔅"
    and "𝔄' = op_cat 𝔄"
    and "ℭ' = op_cat "
  shows "op_ntcf ε : 𝔗' CF.lKe.pwα 𝔊' CF 𝔎' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_pw_lKe_op)

lemmas [cat_op_intros] = is_cat_pw_rKe.is_cat_pw_lKe_op'

lemma (in is_cat_pw_lKe) is_cat_pw_rKe_op:
  "op_ntcf η :
    op_cf 𝔉 CF op_cf 𝔎 CF.rKe.pwα op_cf 𝔗 :
    op_cat 𝔅 C op_cat  C op_cat 𝔄"
proof(intro is_cat_pw_rKeI, unfold cat_op_simps)
  fix a assume prems: "a  𝔄Obj"
  from cat_pw_lKe_preserved[unfolded cat_op_simps, OF prems] prems show 
    "op_ntcf η :
      op_cf 𝔉 CF op_cf 𝔎 CF.rKeα op_cf 𝔗 :
      op_cat 𝔅 C op_cat  C
      (HomO.Cαop_cat 𝔄(a,-) : op_cat 𝔄 ↦↦C cat_Set α)"
    by (cs_concl cs_simp: cat_op_simps cs_intro: cat_cs_intros)    
qed (cs_concl cs_intro: cat_op_intros)

lemma (in is_cat_pw_lKe) is_cat_pw_lKe_op'[cat_op_intros]:
  assumes "𝔗' = op_cf 𝔗"
    and "𝔉' = op_cf 𝔉"
    and "𝔎' = op_cf 𝔎"
    and "𝔅' = op_cat 𝔅"
    and "𝔄' = op_cat 𝔄"
    and "ℭ' = op_cat "
  shows "op_ntcf η : 𝔉' CF 𝔎' CF.rKe.pwα 𝔗' : 𝔅' C ℭ' C 𝔄'"
  unfolding assms by (rule is_cat_pw_rKe_op)

lemmas [cat_op_intros] = is_cat_pw_lKe.is_cat_pw_lKe_op'



(*FIXME: any reason not to generalize and include in CZH_UCAT_Hom?*)
subsection‹Cone functor›


subsubsection‹Definition and elementary properties›

definition cf_Cone :: "V  V  V  V"
  where "cf_Cone α β 𝔉 = 
    HomO.Cβcat_Funct α (𝔉HomDom) (𝔉HomCod)(-,cf_map 𝔉) CF
    op_cf (ΔC α (𝔉HomDom) (𝔉HomCod))"


text‹An alternative form of the definition.›

context is_functor
begin

lemma cf_Cone_def': 
  "cf_Cone α β 𝔉 = HomO.Cβcat_Funct α 𝔄 𝔅(-,cf_map 𝔉) CF op_cf (ΔC α 𝔄 𝔅)"
  unfolding cf_Cone_def cat_cs_simps by simp

end


subsubsection‹Object map›

lemma (in is_tm_functor) cf_Cone_ObjMap_vsv[cat_Kan_cs_intros]:
  assumes "𝒵 β" and "α  β" 
  shows "vsv (cf_Cone α β 𝔉ObjMap)"
proof-
  from assms interpret β: 𝒵 β by simp 
  from assms interpret Δ: is_functor α 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms assms(2) interpret βΔ: 
    is_functor β 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cone_def
    by
      (
        cs_concl 
          cs_simp: cat_cs_simps cat_Funct_components(1) cat_op_simps 
          cs_intro:
            cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_Kan_cs_intros] = is_tm_functor.cf_Cone_ObjMap_vsv

lemma (in is_tm_functor) cf_Cone_ObjMap_vdomain[cat_Kan_cs_simps]:
  assumes "𝒵 β" and "α  β" and "b  𝔅Obj"
  shows "𝒟 (cf_Cone α β 𝔉ObjMap) = 𝔅Obj"
proof-
  from assms interpret β: 𝒵 β by simp 
  from assms interpret Δ: is_functor α 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms assms(2) interpret βΔ: 
    is_functor β 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cone_def'
    by
      (
        cs_concl 
          cs_simp: cat_cs_simps cat_Funct_components(1) cat_op_simps
          cs_intro:
            cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_Kan_cs_simps] = is_tm_functor.cf_Cone_ObjMap_vdomain

lemma (in is_tm_functor) cf_Cone_ObjMap_app[cat_Kan_cs_simps]:
  assumes "𝒵 β"
    and "α  β" 
    and "b  𝔅Obj"
  shows "cf_Cone α β 𝔉ObjMapb =
    Hom (cat_Funct α 𝔄 𝔅) (cf_map (cf_const 𝔄 𝔅 b)) (cf_map 𝔉)"
proof-
  from assms interpret β: 𝒵 β by simp 
  from assms interpret Δ: is_functor α 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms assms(2) interpret βΔ: 
    is_functor β 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from assms(2,3) show ?thesis
    unfolding cf_Cone_def
    by
      (
        cs_concl
          cs_simp: cat_cs_simps cat_Funct_components(1) cat_op_simps
          cs_intro:
            cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_Kan_cs_simps] = is_tm_functor.cf_Cone_ObjMap_app


subsubsection‹Arrow map›

lemma (in is_tm_functor) cf_Cone_ArrMap_vsv[cat_Kan_cs_intros]:
  assumes "𝒵 β" and "α  β" 
  shows "vsv (cf_Cone α β 𝔉ArrMap)"
proof-
  from assms interpret β: 𝒵 β by simp 
  from assms interpret Δ: is_functor α 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms assms(2) interpret βΔ: 
    is_functor β 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cone_def
    by
      (
        cs_concl 
          cs_simp: cat_cs_simps cat_Funct_components(1) cat_op_simps 
          cs_intro:
            cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_Kan_cs_intros] = is_tm_functor.cf_Cone_ArrMap_vsv

lemma (in is_tm_functor) cf_Cone_ArrMap_vdomain[cat_Kan_cs_simps]:
  assumes "𝒵 β" and "α  β" and "b  𝔅Obj"
  shows "𝒟 (cf_Cone α β 𝔉ArrMap) = 𝔅Arr"
proof-
  from assms interpret β: 𝒵 β by simp 
  from assms interpret Δ: is_functor α 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms assms(2) interpret βΔ: 
    is_functor β 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cone_def'
    by
      (
        cs_concl 
          cs_simp: cat_cs_simps cat_Funct_components(1) cat_op_simps
          cs_intro:
            cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_Kan_cs_simps] = is_tm_functor.cf_Cone_ArrMap_vdomain

lemma (in is_tm_functor) cf_Cone_ArrMap_app[cat_Kan_cs_simps]:
  assumes "𝒵 β"
    and "α  β" 
    and "f : a 𝔅 b"
  shows "cf_Cone α β 𝔉ArrMapf = cf_hom
    (cat_Funct α 𝔄 𝔅)
    [ntcf_arrow (ntcf_const 𝔄 𝔅 f), cat_Funct α 𝔄 𝔅CIdcf_map 𝔉]"
proof-
  from assms interpret β: 𝒵 β by simp 
  from assms interpret Δ: is_functor α 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms assms(2) interpret βΔ: 
    is_functor β 𝔅 ‹cat_Funct α 𝔄 𝔅 ΔC α 𝔄 𝔅
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from assms(2,3) show ?thesis
    unfolding cf_Cone_def
    by
      (
        cs_concl
          cs_simp: cat_cs_simps cat_Funct_components(1) cat_op_simps 
          cs_intro:
            cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_Kan_cs_simps] = is_tm_functor.cf_Cone_ArrMap_app


subsubsection‹The cone functor is a functor›

lemma (in is_tm_functor) tm_cf_cf_Cone_is_functor:
  "cf_Cone α α 𝔉 : op_cat 𝔅 ↦↦Cα cat_Set α"
  unfolding cf_Cone_def'
  by
    (
      cs_concl
        cs_simp: cat_op_simps cat_Funct_components(1)
        cs_intro:
          cat_small_cs_intros
          cat_cs_intros
          cat_FUNCT_cs_intros
          cat_op_intros
    )

lemma (in is_tm_functor) tm_cf_cf_Cone_is_functor_if_ge_Limit:
  assumes "𝒵 β" and "α  β"
  shows "cf_Cone α β 𝔉 : op_cat 𝔅 ↦↦Cβ cat_Set β"
proof-
  from assms interpret 𝔄𝔅: category α ‹cat_Funct α 𝔄 𝔅
    by
      (
        cs_concl cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  interpret β_𝔄𝔅: category β ‹cat_Funct α 𝔄 𝔅
    by (rule 𝔄𝔅.cat_category_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros assms)+
  from assms interpret op_Δ: 
    is_tiny_functor β ‹op_cat 𝔅 ‹op_cat (cat_Funct α 𝔄 𝔅) ‹op_cf (ΔC α 𝔄 𝔅)
    by (intro is_functor.cf_is_tiny_functor_if_ge_Limit)
      (
        cs_concl cs_intro:
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  have "HomO.Cβcat_Funct α 𝔄 𝔅(-,cf_map 𝔉) :
    op_cat (cat_Funct α 𝔄 𝔅) ↦↦Cβ cat_Set β"
    by
      (
        cs_concl
          cs_simp: cat_Funct_components(1)
          cs_intro: cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  then show "cf_Cone α β 𝔉 : op_cat 𝔅 ↦↦Cβ cat_Set β"
    unfolding cf_Cone_def'
    by (cs_concl cs_intro: cat_cs_intros)
qed



subsection‹Lemma X.5: L_10_5_N›\label{sec:lem_X_5_start}›


text‹
This subsection and several further subsections 
(\ref{sec:lem_X_5_start}-\ref{sec:lem_X_5_end})
expose definitions that are used in the proof of the technical lemma that
was used in the proof of Theorem 3 from Chapter X-5
in \cite{mac_lane_categories_2010}.
›

definition L_10_5_N :: "V  V  V  V  V  V"
  where "L_10_5_N α β 𝔗 𝔎 c =
    [
      (
        λa𝔗HomCodObj.
          cf_nt α β 𝔎ObjMapcf_map (HomO.Cα𝔗HomCod(a,-) CF 𝔗), c
      ),
      (
        λf𝔗HomCodArr.
          cf_nt α β 𝔎ArrMap
            ntcf_arrow (HomA.Cα𝔗HomCod(f,-) NTCF-CF 𝔗), 𝔎HomCodCIdc
            
      ),
      op_cat (𝔗HomCod),
      cat_Set β
    ]"


text‹Components.›

lemma L_10_5_N_components:
  shows "L_10_5_N α β 𝔗 𝔎 cObjMap =
      (
        λa𝔗HomCodObj.
          cf_nt α β 𝔎ObjMapcf_map (HomO.Cα𝔗HomCod(a,-) CF 𝔗), c
      )"
    and "L_10_5_N α β 𝔗 𝔎 cArrMap =
      (
        λf𝔗HomCodArr.
          cf_nt α β 𝔎ArrMap
            ntcf_arrow (HomA.Cα𝔗HomCod(f,-) NTCF-CF 𝔗), 𝔎HomCodCIdc
            
      )"
    and "L_10_5_N α β 𝔗 𝔎 cHomDom = op_cat (𝔗HomCod)"
    and "L_10_5_N α β 𝔗 𝔎 cHomCod = cat_Set β"
  unfolding L_10_5_N_def dghm_field_simps by (simp_all add: nat_omega_simps)

context
  fixes α 𝔅  𝔄 𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)
interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

lemmas L_10_5_N_components' = L_10_5_N_components[
    where 𝔗=𝔗 and 𝔎=𝔎, unfolded cat_cs_simps
    ]

lemmas [cat_Kan_cs_simps] = L_10_5_N_components'(3,4)

end


subsubsection‹Object map›

mk_VLambda L_10_5_N_components(1)
  |vsv L_10_5_N_ObjMap_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔅  𝔄 𝔎 𝔗 c
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

mk_VLambda L_10_5_N_components'(1)[OF 𝔎 𝔗]
  |vdomain L_10_5_N_ObjMap_vdomain[cat_Kan_cs_simps]|
  |app L_10_5_N_ObjMap_app[cat_Kan_cs_simps]|

end


subsubsection‹Arrow map›

mk_VLambda L_10_5_N_components(2)
  |vsv L_10_5_N_ArrMap_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔅  𝔄 𝔎 𝔗 c
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

mk_VLambda L_10_5_N_components'(2)[OF 𝔎 𝔗]
  |vdomain L_10_5_N_ArrMap_vdomain[cat_Kan_cs_simps]|
  |app L_10_5_N_ArrMap_app[cat_Kan_cs_simps]|

end


subsubsectionL_10_5_N› is a functor›

lemma L_10_5_N_is_functor: 
  assumes "𝒵 β" 
    and "α  β"
    and "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
  shows "L_10_5_N α β 𝔗 𝔎 c : op_cat 𝔄 ↦↦Cβ cat_Set β"
proof-

  let ?FUNCT = λ𝔄. cat_FUNCT α 𝔄 (cat_Set α)

  interpret β: 𝒵 β by (rule assms(1))

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(3))
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(4))

  from assms(2) interpret FUNCT_𝔅: tiny_category β ?FUNCT 𝔅
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  
  interpret β𝔎: is_tiny_functor β 𝔅  𝔎
    by (rule is_functor.cf_is_tiny_functor_if_ge_Limit)
      (use assms(2) in cs_concl cs_intro: cat_cs_intros)+
  interpret β𝔗: is_tiny_functor β 𝔅 𝔄 𝔗
    by (rule is_functor.cf_is_tiny_functor_if_ge_Limit)
      (use assms(2) in cs_concl cs_intro: cat_cs_intros)+

  from assms(2) interpret cf_nt: 
    is_functor β ?FUNCT 𝔅 ×C  ‹cat_Set β ‹cf_nt α β 𝔎
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

  show ?thesis
  proof(intro is_functorI')

    show "vfsequence (L_10_5_N α β 𝔗 𝔎 c)" unfolding L_10_5_N_def by simp
    show "vcard (L_10_5_N α β 𝔗 𝔎 c) = 4" 
      unfolding L_10_5_N_def by (simp add: nat_omega_simps)
    show "vsv (L_10_5_N α β 𝔗 𝔎 cObjMap)" 
      by (cs_concl cs_intro: cat_Kan_cs_intros)
    from assms(3,4) show "vsv (L_10_5_N α β 𝔗 𝔎 cArrMap)"
      by (cs_concl cs_intro: cat_Kan_cs_intros)
    from assms show "𝒟 (L_10_5_N α β 𝔗 𝔎 cObjMap) = op_cat 𝔄Obj"
      by 
        (
          cs_concl 
            cs_simp: cat_Kan_cs_simps cat_op_simps cs_intro: cat_cs_intros
        )
    show " (L_10_5_N α β 𝔗 𝔎 cObjMap)  cat_Set βObj"
      unfolding L_10_5_N_components'[OF 𝔎.is_functor_axioms 𝔗.is_functor_axioms]
    proof(rule vrange_VLambda_vsubset)
      fix a assume prems: "a  𝔄Obj"
      from prems assms show
        "cf_nt α β 𝔎ObjMapcf_map (HomO.Cα𝔄(a,-) CF 𝔗), c 
          cat_Set βObj"
        by 
          (
            cs_concl
              cs_simp: cat_Set_components(1) cat_cs_simps  cat_FUNCT_cs_simps
              cs_intro: 
                cat_cs_intros FUNCT_𝔅.cat_Hom_in_Vset cat_FUNCT_cs_intros
          )
    qed

    from assms show "𝒟 (L_10_5_N α β 𝔗 𝔎 cArrMap) = op_cat 𝔄Arr"
      by 
        (
          cs_concl 
            cs_simp: cat_Kan_cs_simps cat_op_simps cs_intro: cat_cs_intros
        )

    show "L_10_5_N α β 𝔗 𝔎 cArrMapf :
      L_10_5_N α β 𝔗 𝔎 cObjMapa cat_Set β L_10_5_N α β 𝔗 𝔎 cObjMapb"
      if "f : a op_cat 𝔄 b" for a b f
      using that assms
      unfolding cat_op_simps
      by 
        (
          cs_concl 
            cs_simp: L_10_5_N_ArrMap_app L_10_5_N_ObjMap_app 
            cs_intro: cat_cs_intros cat_prod_cs_intros cat_FUNCT_cs_intros
        )

    show 
      "L_10_5_N α β 𝔗 𝔎 cArrMapg Aop_cat 𝔄 f =
        L_10_5_N α β 𝔗 𝔎 cArrMapg Acat_Set β L_10_5_N α β 𝔗 𝔎 cArrMapf"
      if "g : b' op_cat 𝔄 c'" and "f : a' op_cat 𝔄 b'" for b' c' g a' f
    proof-
      from that assms(5) show ?thesis
        unfolding cat_op_simps
        by (*slow*)
          (
            cs_concl
              cs_intro:
                cat_cs_intros
                cat_prod_cs_intros
                cat_FUNCT_cs_intros 
                cat_op_intros
              cs_simp:
                cat_cs_simps
                cat_Kan_cs_simps
                cat_FUNCT_cs_simps 
                cat_prod_cs_simps 
                cat_op_simps
                cf_nt.cf_ArrMap_Comp[symmetric]
          )
    qed

    show 
      "L_10_5_N α β 𝔗 𝔎 cArrMapop_cat 𝔄CIda =
        cat_Set βCIdL_10_5_N α β 𝔗 𝔎 cObjMapa"
      if "a  op_cat 𝔄Obj" for a
    proof-
      note [cat_cs_simps] = 
        ntcf_id_cf_comp[symmetric] 
        ntcf_arrow_id_ntcf_id[symmetric]
        cat_FUNCT_CId_app[symmetric] 
      from that[unfolded cat_op_simps] assms show ?thesis
        by (*slow*)
          (
            cs_concl
              cs_intro:
                cat_cs_intros
                cat_FUNCT_cs_intros
                cat_prod_cs_intros
                cat_op_intros
              cs_simp: 
                cat_FUNCT_cs_simps cat_cs_simps cat_Kan_cs_simps cat_op_simps
          )
    qed

  qed (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)+

qed

lemma L_10_5_N_is_functor'[cat_Kan_cs_intros]: 
  assumes "𝒵 β" 
    and "α  β"
    and "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and "𝔄' = op_cat 𝔄"
    and "𝔅' = cat_Set β"
    and "β' = β"
  shows "L_10_5_N α β 𝔗 𝔎 c : 𝔄' ↦↦Cβ' 𝔅'"
  using assms(1-5) unfolding assms(6-8) by (rule L_10_5_N_is_functor)



subsection‹Lemma X.5: L_10_5_υ_arrow›


subsubsection‹Definition and elementary properties›

definition L_10_5_υ_arrow :: "V  V  V  V  V  V  V"
  where "L_10_5_υ_arrow 𝔗 𝔎 c τ a b =
    [
      (λfHom (𝔎HomCod) c (𝔎ObjMapb). τNTMap0, b, f),
      Hom (𝔎HomCod) c (𝔎ObjMapb),
      Hom (𝔗HomCod) a (𝔗ObjMapb)
    ]"


text‹Components.›

lemma L_10_5_υ_arrow_components:
  shows "L_10_5_υ_arrow 𝔗 𝔎 c τ a bArrVal =
    (λfHom (𝔎HomCod) c (𝔎ObjMapb). τNTMap0, b, f)"
    and "L_10_5_υ_arrow 𝔗 𝔎 c τ a bArrDom = Hom (𝔎HomCod) c (𝔎ObjMapb)"
    and "L_10_5_υ_arrow 𝔗 𝔎 c τ a bArrCod = Hom (𝔗HomCod) a (𝔗ObjMapb)"
  unfolding L_10_5_υ_arrow_def arr_field_simps 
  by (simp_all add: nat_omega_simps) 

context
  fixes α 𝔅  𝔄 𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)
interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

lemmas L_10_5_υ_arrow_components' = L_10_5_υ_arrow_components[
    where 𝔗=𝔗 and 𝔎=𝔎, unfolded cat_cs_simps
    ]

lemmas [cat_Kan_cs_simps] = L_10_5_υ_arrow_components'(2,3)

end


subsubsection‹Arrow value›

mk_VLambda L_10_5_υ_arrow_components(1)
  |vsv L_10_5_υ_arrow_ArrVal_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔅  𝔄 𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

mk_VLambda L_10_5_υ_arrow_components'(1)[OF 𝔎 𝔗]
  |vdomain L_10_5_υ_arrow_ArrVal_vdomain[cat_Kan_cs_simps]|
  |app L_10_5_υ_arrow_ArrVal_app[unfolded in_Hom_iff]|

end

lemma L_10_5_υ_arrow_ArrVal_app':
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "f : c  𝔎ObjMapb"
  shows "L_10_5_υ_arrow 𝔗 𝔎 c τ a bArrValf = τNTMap0, b, f"
proof-
  interpret 𝔎: is_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  from assms(3) have c: "c  Obj" by auto
  show ?thesis by (rule L_10_5_υ_arrow_ArrVal_app[OF assms(1,2,3)])
qed


subsubsectionL_10_5_υ_arrow› is an arrow›

lemma L_10_5_υ_arrow_ArrVal_is_arr: 
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "τ' = ntcf_arrow τ"
    and "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "f : c  𝔎ObjMapb"
    and "b  𝔅Obj"
  shows "L_10_5_υ_arrow 𝔗 𝔎 c τ' a bArrValf : a 𝔄 𝔗ObjMapb"
proof-
  interpret 𝔎: is_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  interpret τ: is_cat_cone α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 τ by (rule assms(4))
  from assms(5,6) show ?thesis
    unfolding assms(3)
    by
      (
        cs_concl
          cs_simp:
            cat_cs_simps
            L_10_5_υ_arrow_ArrVal_app
            cat_comma_cs_simps
            cat_FUNCT_cs_simps
          cs_intro: cat_cs_intros cat_comma_cs_intros
      )
qed

lemma L_10_5_υ_arrow_ArrVal_is_arr'[cat_Kan_cs_intros]: 
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "τ' = ntcf_arrow τ"
    and "a' = a"
    and "b' = 𝔗ObjMapb"
    and "𝔄' = 𝔄"
    and "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "f : c  𝔎ObjMapb"
    and "b  𝔅Obj"
  shows "L_10_5_υ_arrow 𝔗 𝔎 c τ' a bArrValf : a' 𝔄 b'"
  using assms(1-3, 7-9) 
  unfolding assms(3-6) 
  by (rule L_10_5_υ_arrow_ArrVal_is_arr)


subsubsection‹Further elementary properties›

lemma L_10_5_υ_arrow_is_arr: 
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c  Obj"
    and "τ' = ntcf_arrow τ"
    and "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "b  𝔅Obj"
  shows "L_10_5_υ_arrow 𝔗 𝔎 c τ' a b :
    Hom  c (𝔎ObjMapb) cat_Set α Hom 𝔄 a (𝔗ObjMapb)"
proof-
  note L_10_5_υ_arrow_components = L_10_5_υ_arrow_components'[OF assms(1,2)]
  interpret 𝔎: is_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  interpret τ: is_cat_cone α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 τ by (rule assms(5))
  show ?thesis
  proof(intro cat_Set_is_arrI)
    show "arr_Set α (L_10_5_υ_arrow 𝔗 𝔎 c τ' a b)"
    proof(intro arr_SetI)
      show "vfsequence (L_10_5_υ_arrow 𝔗 𝔎 c τ' a b)" 
        unfolding L_10_5_υ_arrow_def by simp
      show "vcard (L_10_5_υ_arrow 𝔗 𝔎 c τ' a b) = 3"
        unfolding L_10_5_υ_arrow_def by (simp add: nat_omega_simps)
      show 
        " (L_10_5_υ_arrow 𝔗 𝔎 c τ' a bArrVal) 
          L_10_5_υ_arrow 𝔗 𝔎 c τ' a bArrCod"
        unfolding L_10_5_υ_arrow_components
      proof(intro vrange_VLambda_vsubset, unfold in_Hom_iff)
        fix f assume "f : c  𝔎ObjMapb"
        from L_10_5_υ_arrow_ArrVal_is_arr[OF assms(1,2,4,5) this assms(6)] this 
        show "τ'NTMap0, b, f : a 𝔄 𝔗ObjMapb"
          by 
            (
              cs_prems 
                cs_simp: L_10_5_υ_arrow_ArrVal_app' cat_cs_simps 
                cs_intro: cat_cs_intros
            ) 
      qed
      from assms(3,6) show "L_10_5_υ_arrow 𝔗 𝔎 c τ' a bArrDom  Vset α"
        by (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)
      from assms(1-3,6) τ.cat_cone_obj show
        "L_10_5_υ_arrow 𝔗 𝔎 c τ' a bArrCod  Vset α"
        by (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)
    qed (auto simp: L_10_5_υ_arrow_components)
  qed (simp_all add: L_10_5_υ_arrow_components)
qed

lemma L_10_5_υ_arrow_is_arr'[cat_Kan_cs_intros]: 
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c  Obj"
    and "τ' = ntcf_arrow τ"
    and "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "b  𝔅Obj"
    and "A = Hom  c (𝔎ObjMapb)"
    and "B = Hom 𝔄 a (𝔗ObjMapb)"
    and "ℭ' = cat_Set α"
  shows "L_10_5_υ_arrow 𝔗 𝔎 c τ' a b : A ℭ' B"
  using assms(1-6) unfolding assms(7-9) by (rule L_10_5_υ_arrow_is_arr)

lemma L_10_5_υ_cf_hom[cat_Kan_cs_simps]:
  assumes "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c  Obj"
    and "τ' = ntcf_arrow τ"
    and "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "a  𝔄Obj"
    and "f : a' 𝔅 b'"
  shows 
    "L_10_5_υ_arrow 𝔗 𝔎 c τ' a b' Acat_Set α
    cf_hom  [CIdc, 𝔎ArrMapf] =
      cf_hom 𝔄 [𝔄CIda, 𝔗ArrMapf] Acat_Set α
      L_10_5_υ_arrow 𝔗 𝔎 c τ' a a'"
    (is "?lhs = ?rhs")
proof-

  interpret 𝔎: is_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  interpret τ: is_cat_cone α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 τ by (rule assms(5))

  have [cat_Kan_cs_simps]:
    "τNTMapa'', b'', 𝔎ArrMaph' A f' = 
      𝔗ArrMaph' A𝔄 τNTMapa', b', f'"
    if F_def: "F = [[a', b', f'], [a'', b'', f''], [g', h']]"
      and A_def: "A = [a', b', f']"
      and B_def: "B = [a'', b'', f'']"
      and F: "F : A c CF 𝔎 B"
    for F A B a' b' f' a'' b'' f'' g' h'
  proof-
    from F[unfolded F_def A_def B_def] assms(3) have a'_def: "a' = 0"
      and a''_def: "a'' = 0"
      and g'_def: "g' = 0"
      and h': "h' : b' 𝔅 b''"
      and f': "f' : c  𝔎ObjMapb'"
      and f'': "f'' : c  𝔎ObjMapb''"
      and f''_def: "𝔎ArrMaph' A f' = f''"
      by auto
    from 
      τ.ntcf_Comp_commute[OF F] 
      that(2) F g' h' f' f'' 
      𝔎.is_functor_axioms 
      𝔗.is_functor_axioms 
    show 
      "τNTMapa'', b'', 𝔎ArrMaph' A f' = 
        𝔗ArrMaph' A𝔄 τNTMapa', b', f'"
      unfolding F_def A_def B_def a'_def a''_def g'_def 
      by (*slow*)
        (
          cs_prems 1
            cs_simp: cat_cs_simps cat_comma_cs_simps f''_def[symmetric]
            cs_intro: cat_cs_intros cat_comma_cs_intros
        )
  qed

  from assms(3) assms(6,7) 𝔎.HomCod.category_axioms have lhs_is_arr:
    "?lhs : Hom  c (𝔎ObjMapa') cat_Set α Hom 𝔄 a (𝔗ObjMapb')"
    unfolding assms(4)
    by
      (
        cs_concl cs_simp: cs_intro:
          cat_lim_cs_intros 
          cat_cs_intros 
          cat_Kan_cs_intros 
          cat_prod_cs_intros 
          cat_op_intros
      )
  then have dom_lhs: "𝒟 ((?lhs)ArrVal) = Hom  c (𝔎ObjMapa')" 
    by (cs_concl cs_simp: cat_cs_simps)
  from assms(3) assms(6,7) 𝔎.HomCod.category_axioms 𝔗.HomCod.category_axioms 
  have rhs_is_arr:
    "?rhs : Hom  c (𝔎ObjMapa') cat_Set α Hom 𝔄 a (𝔗ObjMapb')"
    unfolding assms(4)
    by
      (
        cs_concl cs_intro:
          cat_lim_cs_intros 
          cat_cs_intros 
          cat_Kan_cs_intros 
          cat_prod_cs_intros 
          cat_op_intros
      )
  then have dom_rhs: "𝒟 ((?rhs)ArrVal) = Hom  c (𝔎ObjMapa')" 
    by (cs_concl cs_simp: cat_cs_simps)
  show ?thesis
  proof(rule arr_Set_eqI)
    from lhs_is_arr show arr_Set_lhs: "arr_Set α ?lhs"
      by (auto dest: cat_Set_is_arrD(1))
    from rhs_is_arr show arr_Set_rhs: "arr_Set α ?rhs"
      by (auto dest: cat_Set_is_arrD(1))
    show "?lhsArrVal = ?rhsArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
      fix g assume prems: "g : c  𝔎ObjMapa'"
      from prems assms(7) have 𝔎f: 
        "𝔎ArrMapf A g : c  𝔎ObjMapb'"
        by (cs_concl cs_intro: cat_cs_intros)
      with assms(6,7) prems 𝔎.HomCod.category_axioms 𝔗.HomCod.category_axioms 
      show "?lhsArrValg = ?rhsArrValg"
          by (*slow*)
            (
              cs_concl
                cs_intro:
                  cat_lim_cs_intros 
                  cat_cs_intros 
                  cat_Kan_cs_intros
                  cat_comma_cs_intros
                  cat_prod_cs_intros 
                  cat_op_intros 
                  cat_1_is_arrI
                cs_simp:
                  L_10_5_υ_arrow_ArrVal_app' 
                  cat_cs_simps
                  cat_Kan_cs_simps
                  cat_op_simps
                  cat_FUNCT_cs_simps
                  cat_comma_cs_simps
                  assms(4)
            )+
    qed (use arr_Set_lhs arr_Set_rhs in auto)
  qed
    (
      use lhs_is_arr rhs_is_arr in
        cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros
    )+
qed



subsection‹Lemma X.5: L_10_5_τ›


subsubsection‹Definition and elementary properties›

definition L_10_5_τ where "L_10_5_τ 𝔗 𝔎 c υ a = 
  [
    (λbfc CF 𝔎Obj. υNTMapbf1ArrValbf2),
    cf_const (c CF 𝔎) (𝔗HomCod) a,
    𝔗 CF c OCF 𝔎,
    c CF 𝔎,
    (𝔗HomCod)
  ]"


text‹Components.›

lemma L_10_5_τ_components: 
  shows "L_10_5_τ 𝔗 𝔎 c υ aNTMap =
    (λbfc CF 𝔎Obj. υNTMapbf1ArrValbf2)"
    and "L_10_5_τ 𝔗 𝔎 c υ aNTDom = cf_const (c CF 𝔎) (𝔗HomCod) a"
    and "L_10_5_τ 𝔗 𝔎 c υ aNTCod = 𝔗 CF c OCF 𝔎"
    and "L_10_5_τ 𝔗 𝔎 c υ aNTDGDom = c CF 𝔎"
    and "L_10_5_τ 𝔗 𝔎 c υ aNTDGCod = (𝔗HomCod)"
  unfolding L_10_5_τ_def nt_field_simps by (simp_all add: nat_omega_simps)

context
  fixes α 𝔅  𝔄 𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)
interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

lemmas L_10_5_τ_components' = L_10_5_τ_components[
  where 𝔗=𝔗 and 𝔎=𝔎, unfolded cat_cs_simps
  ]

lemmas [cat_Kan_cs_simps] = L_10_5_τ_components'(2-5)

end


subsubsection‹Natural transformation map›

mk_VLambda L_10_5_τ_components(1)
  |vsv L_10_5_τ_NTMap_vsv[cat_Kan_cs_intros]|
  |vdomain L_10_5_τ_NTMap_vdomain[cat_Kan_cs_simps]|

lemma L_10_5_τ_NTMap_app[cat_Kan_cs_simps]: 
  assumes "bf = [0, b, f]" and "bf  c CF 𝔎Obj" 
  shows "L_10_5_τ 𝔗 𝔎 c υ aNTMapbf = υNTMapbArrValf"
  using assms unfolding L_10_5_τ_components by (simp add: nat_omega_simps)


subsubsectionL_10_5_τ› is a cone›

lemma L_10_5_τ_is_cat_cone[cat_cs_intros]:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and υ'_def: "υ' = ntcf_arrow υ"
    and υ: "υ :
      HomO.Cα(c,-) CF 𝔎 CF HomO.Cα𝔄(a,-) CF 𝔗 : 𝔅 ↦↦Cα cat_Set α"
    and a: "a  𝔄Obj"
  shows "L_10_5_τ 𝔗 𝔎 c υ' a : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
proof-

  let ?H_ℭ = λc. HomO.Cα(c,-) 
  let ?H_𝔄 = λa. HomO.Cα𝔄(a,-)

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(2))

  from assms(3) interpret c𝔎: tiny_category α c CF 𝔎
    by (cs_concl cs_intro: cat_comma_cs_intros)
  from assms(3) interpret Πc: is_tm_functor α c CF 𝔎 𝔅 c OCF 𝔎
    by
      (
        cs_concl
          cs_simp: cat_comma_cs_simps 
          cs_intro: cat_small_cs_intros cat_cs_intros cat_comma_cs_intros
      )
  interpret υ: is_ntcf α 𝔅 ‹cat_Set α ?H_ℭ c CF 𝔎 ?H_𝔄 a CF 𝔗 υ
    by (rule υ)

  show ?thesis
  proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')
    show "vfsequence (L_10_5_τ 𝔗 𝔎 c υ' a)" unfolding L_10_5_τ_def by simp
    show "vcard (L_10_5_τ 𝔗 𝔎 c υ' a) = 5" 
      unfolding L_10_5_τ_def by (simp add: nat_omega_simps)
    from a interpret cf_const:
      is_tm_functor α c CF 𝔎 𝔄 ‹cf_const (c CF 𝔎) 𝔄 a 
      by (cs_concl cs_intro: cat_small_cs_intros cat_cs_intros)
    show "L_10_5_τ 𝔗 𝔎 c υ' aNTMapbf :
      cf_const (c CF 𝔎) 𝔄 aObjMapbf 𝔄 (𝔗 CF c OCF 𝔎)ObjMapbf"
      if "bf  c CF 𝔎Obj" for bf
    proof-
      from that assms(3) obtain b f 
        where bf_def: "bf = [0, b, f]"
          and b: "b  𝔅Obj"
          and f: "f : c  𝔎ObjMapb"
        by auto
      from υ.ntcf_NTMap_is_arr[OF b] a b assms(3) f have "υNTMapb :
        Hom  c (𝔎ObjMapb) cat_Set α Hom 𝔄 a (𝔗ObjMapb)"
        by
          (
            cs_prems 
              cs_simp: cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros
          )
      with that b f show "L_10_5_τ 𝔗 𝔎 c υ' aNTMapbf :
        cf_const (c CF 𝔎) 𝔄 aObjMapbf 𝔄 (𝔗 CF c OCF 𝔎)ObjMapbf"
        unfolding bf_def υ'_def
        by
          (
            cs_concl
              cs_simp:
                cat_cs_simps 
                cat_Kan_cs_simps 
                cat_comma_cs_simps
                cat_FUNCT_cs_simps
              cs_intro: cat_cs_intros cat_comma_cs_intros
          )
    qed

    show 
      "L_10_5_τ 𝔗 𝔎 c υ' aNTMapB A𝔄 cf_const (c CF 𝔎) 𝔄 aArrMapF =
        (𝔗 CF c OCF 𝔎)ArrMapF A𝔄 L_10_5_τ 𝔗 𝔎 c υ' aNTMapA"
      if "F : A c CF 𝔎 B" for A B F
    proof-
      from 𝔎.is_functor_axioms that assms(3) obtain a' f a'' f' g 
        where F_def: "F = [[0, a', f], [0, a'', f'], [0, g]]"
          and A_def: "A = [0, a', f]"
          and B_def: "B = [0, a'', f']"
          and g: "g : a' 𝔅 a''"
          and f: "f : c  𝔎ObjMapa'"
          and f': "f' : c  𝔎ObjMapa''" 
          and f'_def: "𝔎ArrMapg A f = f'" 
        by auto
      from υ.ntcf_Comp_commute[OF g] have 
        "(υNTMapa'' Acat_Set α (?H_ℭ c CF 𝔎)ArrMapg)ArrValf =
          ((?H_𝔄 a CF 𝔗)ArrMapg Acat_Set α υNTMapa')ArrValf"
        by simp
      from this a g f f' 𝔎.HomCod.category_axioms 𝔗.HomCod.category_axioms 
      have [cat_cs_simps]:
        "υNTMapa''ArrVal𝔎ArrMapg A f = 
          𝔗ArrMapg A𝔄 υNTMapa'ArrValf"
        by (*slow*)
          (
            cs_prems
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_prod_cs_intros cat_op_intros
          )
      from that a g f f' 𝔎.HomCod.category_axioms 𝔗.HomCod.category_axioms 
      show ?thesis
        unfolding F_def A_def B_def υ'_def (*slow*)
        by
          (
            cs_concl
              cs_simp:
                f'_def[symmetric] 
                cat_cs_simps 
                cat_Kan_cs_simps 
                cat_comma_cs_simps 
                cat_FUNCT_cs_simps
                cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros
          )
    qed

  qed
    (
      use assms in
        cs_concl
            cs_simp: cat_cs_simps cat_Kan_cs_simps 
            cs_intro: cat_small_cs_intros cat_cs_intros cat_Kan_cs_intros a
        ›
    )+

qed

lemma L_10_5_τ_is_cat_cone'[cat_Kan_cs_intros]:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and "υ' = ntcf_arrow υ"
    and "𝔉' = 𝔗 CF c OCF 𝔎"
    and "c𝔎 = c CF 𝔎"
    and "𝔄' = 𝔄"
    and "α' = α"
    and "υ :
      HomO.Cα(c,-) CF 𝔎 CF HomO.Cα𝔄(a,-) CF 𝔗 :
      𝔅 ↦↦Cα cat_Set α"
    and "a  𝔄Obj"
  shows "L_10_5_τ 𝔗 𝔎 c υ' a : a <CF.cone 𝔉' : c𝔎 ↦↦Cα' 𝔄'"
  using assms(1-4,9,10) unfolding assms(5-8) by (rule L_10_5_τ_is_cat_cone)



subsection‹Lemma X.5: L_10_5_υ›


subsubsection‹Definition and elementary properties›

definition L_10_5_υ :: "V  V  V  V  V  V  V"
  where "L_10_5_υ α 𝔗 𝔎 c τ a =
    [
      (λb𝔗HomDomObj. L_10_5_υ_arrow 𝔗 𝔎 c τ a b),
      HomO.Cα𝔎HomCod(c,-) CF 𝔎,
      HomO.Cα𝔗HomCod(a,-) CF 𝔗,
      𝔗HomDom,
      cat_Set α
    ]"


text‹Components.›

lemma L_10_5_υ_components: 
  shows "L_10_5_υ α 𝔗 𝔎 c τ aNTMap =
    (λb𝔗HomDomObj. L_10_5_υ_arrow 𝔗 𝔎 c τ a b)"
    and "L_10_5_υ α 𝔗 𝔎 c τ aNTDom = HomO.Cα𝔎HomCod(c,-) CF 𝔎"
    and "L_10_5_υ α 𝔗 𝔎 c τ aNTCod = HomO.Cα𝔗HomCod(a,-) CF 𝔗"
    and "L_10_5_υ α 𝔗 𝔎 c τ aNTDGDom = 𝔗HomDom"
    and "L_10_5_υ α 𝔗 𝔎 c τ aNTDGCod = cat_Set α"
  unfolding L_10_5_υ_def nt_field_simps by (simp_all add: nat_omega_simps)

context
  fixes α 𝔅  𝔄 𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)
interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

lemmas L_10_5_υ_components' = L_10_5_υ_components[
  where 𝔗=𝔗 and 𝔎=𝔎, unfolded cat_cs_simps
  ]

lemmas [cat_Kan_cs_simps] = L_10_5_υ_components'(2-5)

end


subsubsection‹Natural transformation map›

mk_VLambda L_10_5_υ_components(1)
  |vsv L_10_5_υ_NTMap_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔅  𝔄 𝔎 𝔗
  assumes 𝔎: "𝔎 : 𝔅 ↦↦Cα "
    and 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation 𝔎: is_functor α 𝔅  𝔎 by (rule 𝔎)
interpretation 𝔗: is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

mk_VLambda L_10_5_υ_components'(1)[OF 𝔎 𝔗]
  |vdomain L_10_5_υ_NTMap_vdomain[cat_Kan_cs_simps]|
  |app L_10_5_υ_NTMap_app[cat_Kan_cs_simps]|

end


subsubsectionL_10_5_υ› is a natural transformation›

lemma L_10_5_υ_is_ntcf:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and τ'_def: "τ' = ntcf_arrow τ"
    and τ: "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and a: "a  𝔄Obj"
  shows "L_10_5_υ α 𝔗 𝔎 c τ' a :
    HomO.Cα(c,-) CF 𝔎 CF HomO.Cα𝔄(a,-) CF 𝔗 : 𝔅 ↦↦Cα cat_Set α"
    (is ?L_10_5_υ : ?H_ℭ c CF 𝔎 CF ?H_𝔄 a CF 𝔗 : 𝔅 ↦↦Cα cat_Set α)
proof-

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(2))

  interpret τ: is_cat_cone α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 τ  
    by (rule assms(5))

  from assms(3) interpret c𝔎: tiny_category α c CF 𝔎
    by (cs_concl cs_intro: cat_comma_cs_intros)
  from assms(3) interpret Πc: is_tm_functor α c CF 𝔎 𝔅 c OCF 𝔎
    by
      (
        cs_concl
          cs_simp: cat_comma_cs_simps 
          cs_intro: cat_small_cs_intros cat_cs_intros cat_comma_cs_intros
      )

  show "?L_10_5_υ : ?H_ℭ c CF 𝔎 CF ?H_𝔄 a CF 𝔗 : 𝔅 ↦↦Cα cat_Set α"
  proof(intro is_ntcfI')
    show "vfsequence ?L_10_5_υ" unfolding L_10_5_υ_def by auto
    show "vcard ?L_10_5_υ = 5" 
      unfolding L_10_5_υ_def by (simp add: nat_omega_simps)
    show "?L_10_5_υNTMapb :
      (?H_ℭ c CF 𝔎)ObjMapb cat_Set α (?H_𝔄 a CF 𝔗)ObjMapb"
      if "b  𝔅Obj" for b
    proof-
      from a that assms(3) show ?thesis
        unfolding τ'_def
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_Kan_cs_simps
              cs_intro:
                cat_Kan_cs_intros
                cat_lim_cs_intros
                cat_cs_intros
                cat_op_intros
          )
    qed
    show
      "?L_10_5_υNTMapb' Acat_Set α (?H_ℭ c CF 𝔎)ArrMapf =
        (?H_𝔄 a CF 𝔗)ArrMapf Acat_Set α ?L_10_5_υNTMapa'"
      if "f : a' 𝔅 b'" for a' b' f
    proof-
      from that a assms(3) show ?thesis
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_Kan_cs_simps cat_op_simps τ'_def
              cs_intro: cat_lim_cs_intros cat_cs_intros 
          )
    qed

  qed
    (
      use assms(3,6) in
        cs_concl
            cs_simp: cat_cs_simps cat_Kan_cs_simps
            cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed

lemma L_10_5_υ_is_ntcf'[cat_Kan_cs_intros]:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and "τ' = ntcf_arrow τ"
    and "𝔉' = HomO.Cα(c,-) CF 𝔎"
    and "𝔊' = HomO.Cα𝔄(a,-) CF 𝔗"
    and "𝔅' = 𝔅"
    and "ℭ' = cat_Set α"
    and "α' = α"
    and "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and "a  𝔄Obj"
  shows "L_10_5_υ α 𝔗 𝔎 c τ' a : 𝔉' CF 𝔊' : 𝔅' ↦↦Cα' ℭ'"
  using assms(1-4,10,11) unfolding assms(5-9) by (rule L_10_5_υ_is_ntcf)



subsection‹Lemma X.5: L_10_5_χ_arrow›


subsubsection‹Definition and elementary properties›

definition L_10_5_χ_arrow 
  where "L_10_5_χ_arrow α β 𝔗 𝔎 c a =
    [
      (λυL_10_5_N α β 𝔗 𝔎 cObjMapa. ntcf_arrow (L_10_5_τ 𝔗 𝔎 c υ a)), 
      L_10_5_N α β 𝔗 𝔎 cObjMapa,
      cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa
    ]"


text‹Components.›

lemma L_10_5_χ_arrow_components: 
  shows "L_10_5_χ_arrow α β 𝔗 𝔎 c aArrVal = 
      (λυL_10_5_N α β 𝔗 𝔎 cObjMapa. ntcf_arrow (L_10_5_τ 𝔗 𝔎 c υ a))"
    and "L_10_5_χ_arrow α β 𝔗 𝔎 c aArrDom = L_10_5_N α β 𝔗 𝔎 cObjMapa"
    and "L_10_5_χ_arrow α β 𝔗 𝔎 c aArrCod = 
      cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa"
  unfolding L_10_5_χ_arrow_def arr_field_simps
  by (simp_all add: nat_omega_simps)

lemmas [cat_Kan_cs_simps] = L_10_5_χ_arrow_components(2,3)


subsubsection‹Arrow value›

mk_VLambda L_10_5_χ_arrow_components(1)
  |vsv L_10_5_χ_arrow_vsv[cat_Kan_cs_intros]|
  |vdomain L_10_5_χ_arrow_vdomain|
  |app L_10_5_χ_arrow_app|

lemma L_10_5_χ_arrow_vdomain'[cat_Kan_cs_simps]:
  assumes "𝒵 β"
    and "α  β"
    and "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c  Obj"
    and "a  𝔄Obj"
  shows "𝒟 (L_10_5_χ_arrow α β 𝔗 𝔎 c aArrVal) = Hom 
    (cat_FUNCT α 𝔅 (cat_Set α)) 
    (cf_map (HomO.Cα(c,-) CF 𝔎)) 
    (cf_map (HomO.Cα𝔄(a,-) CF 𝔗))"
  using assms
  by
    (
      cs_concl 
        cs_simp: cat_cs_simps cat_Kan_cs_simps L_10_5_χ_arrow_vdomain 
        cs_intro: cat_cs_intros
    )

lemma L_10_5_χ_arrow_app'[cat_Kan_cs_simps]:
  assumes "𝒵 β"
    and "α  β"
    and "𝔎 : 𝔅 ↦↦Cα "
    and "𝔗 : 𝔅 ↦↦Cα 𝔄"
    and "c  Obj"
    and υ'_def: "υ' = ntcf_arrow υ"
    and υ: "υ :
      HomO.Cα(c,-) CF 𝔎 CF HomO.Cα𝔄(a,-) CF 𝔗 : 𝔅 ↦↦Cα cat_Set α"
    and a: "a  𝔄Obj"
  shows 
    "L_10_5_χ_arrow α β 𝔗 𝔎 c aArrValυ' =
      ntcf_arrow (L_10_5_τ 𝔗 𝔎 c υ' a)"
  using assms
  by
    (
      cs_concl
        cs_simp: cat_cs_simps cat_Kan_cs_simps L_10_5_χ_arrow_app 
        cs_intro: cat_cs_intros cat_FUNCT_cs_intros
    )

lemma υτa_def:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and υτa'_def: "υτa' = ntcf_arrow υτa"
    and υτa: "υτa :
      HomO.Cα(c,-) CF 𝔎 CF HomO.Cα𝔄(a,-) CF 𝔗 :
      𝔅 ↦↦Cα cat_Set α"
    and a: "a  𝔄Obj"
  shows "υτa = L_10_5_υ α 𝔗 𝔎 c (ntcf_arrow (L_10_5_τ 𝔗 𝔎 c υτa' a)) a"
  (is υτa = ?L_10_5_υ (ntcf_arrow ?L_10_5_τ) a)
proof-

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(2))

  interpret υτa: is_ntcf 
    α 𝔅 ‹cat_Set α HomO.Cα(c,-) CF 𝔎 HomO.Cα𝔄(a,-) CF 𝔗 υτa
    by (rule υτa)

  show ?thesis
  proof(rule ntcf_eqI)
    show "υτa : 
      HomO.Cα(c,-) CF 𝔎 CF HomO.Cα𝔄(a,-) CF 𝔗 : 𝔅 ↦↦Cα cat_Set α"
      by (rule υτa)
    from assms(1-3) a show 
      "?L_10_5_υ (ntcf_arrow ?L_10_5_τ) a :
        HomO.Cα(c,-) CF 𝔎 CF HomO.Cα𝔄(a,-) CF 𝔗 : 𝔅 ↦↦Cα cat_Set α" 
      by
        (
          cs_concl
            cs_simp: cat_Kan_cs_simps υτa'_def
            cs_intro: cat_cs_intros cat_Kan_cs_intros
        )
    have dom_lhs: "𝒟 (υτaNTMap) = 𝔅Obj"
      by (cs_concl cs_simp: cat_cs_simps)
    have dom_rhs: "𝒟 (?L_10_5_υ (ntcf_arrow (?L_10_5_τ)) aNTMap) = 𝔅Obj"
      by (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)
    show "υτaNTMap = ?L_10_5_υ (ntcf_arrow ?L_10_5_τ) aNTMap"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix b assume prems: "b  𝔅Obj"
      from prems assms(3) a have lhs: "υτaNTMapb :
        Hom  c (𝔎ObjMapb) cat_Set α Hom 𝔄 a (𝔗ObjMapb)"
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
          )
      then have dom_lhs: "𝒟 (υτaNTMapbArrVal) = Hom  c (𝔎ObjMapb)"
        by (cs_concl cs_simp: cat_cs_simps)
      from prems assms(3) a have rhs: 
        "L_10_5_υ_arrow 𝔗 𝔎 c (ntcf_arrow ?L_10_5_τ) a b :
          Hom  c (𝔎ObjMapb) cat_Set α Hom 𝔄 a (𝔗ObjMapb)"
        unfolding υτa'_def
        by
          (
            cs_concl 
              cs_simp: cat_Kan_cs_simps 
              cs_intro: cat_small_cs_intros cat_Kan_cs_intros cat_cs_intros
          )

      then have dom_rhs: 
        "𝒟 (L_10_5_υ_arrow 𝔗 𝔎 c  (ntcf_arrow ?L_10_5_τ) a bArrVal) =
          Hom  c (𝔎ObjMapb)"
        by (cs_concl cs_simp: cat_cs_simps)
      have [cat_cs_simps]:  
        "υτaNTMapb = L_10_5_υ_arrow 𝔗 𝔎 c (ntcf_arrow ?L_10_5_τ) a b"
      proof(rule arr_Set_eqI)
        from lhs show arr_Set_lhs: "arr_Set α (υτaNTMapb)"
          by (auto dest: cat_Set_is_arrD(1))
        from rhs show arr_Set_rhs: 
          "arr_Set α (L_10_5_υ_arrow 𝔗 𝔎 c (ntcf_arrow (?L_10_5_τ)) a b)"
          by (auto dest: cat_Set_is_arrD(1))
        show "υτaNTMapbArrVal = 
          L_10_5_υ_arrow 𝔗 𝔎 c (ntcf_arrow ?L_10_5_τ) a bArrVal"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
          fix f assume "f : c  𝔎ObjMapb"
          with assms prems show 
            "υτaNTMapbArrValf =
              L_10_5_υ_arrow 𝔗 𝔎 c (ntcf_arrow ?L_10_5_τ) a bArrValf"
            unfolding υτa'_def
            by
              (
                cs_concl
                  cs_simp:
                    cat_Kan_cs_simps cat_FUNCT_cs_simps L_10_5_υ_arrow_ArrVal_app 
                  cs_intro: cat_cs_intros cat_comma_cs_intros
              )
        qed (use arr_Set_lhs arr_Set_rhs in auto)
      qed (use lhs rhs in cs_concl cs_simp: cat_cs_simps)+

      from prems show 
        "υτaNTMapb = L_10_5_υ α 𝔗 𝔎 c (ntcf_arrow ?L_10_5_τ) aNTMapb"
        by
          (
            cs_concl 
              cs_simp: cat_cs_simps cat_Kan_cs_simps cs_intro: cat_cs_intros
          )

    qed (cs_concl cs_intro: cat_cs_intros cat_Kan_cs_intros V_cs_intros)+

  qed simp_all

qed



subsection‹Lemma X.5: L_10_5_χ'_arrow›


subsubsection‹Definition and elementary properties›

definition L_10_5_χ'_arrow :: "V  V  V  V  V  V  V"
  where "L_10_5_χ'_arrow α β 𝔗 𝔎 c a =
    [
      (
        λτcf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa.
          ntcf_arrow (L_10_5_υ α 𝔗 𝔎 c τ a)
      ),
      cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa,
      L_10_5_N α β 𝔗 𝔎 cObjMapa
    ]"


text‹Components.›

lemma L_10_5_χ'_arrow_components:
  shows "L_10_5_χ'_arrow α β 𝔗 𝔎 c aArrVal =
    (
      λτcf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa.
        ntcf_arrow (L_10_5_υ α 𝔗 𝔎 c τ a)
    )"
    and [cat_Kan_cs_simps]: "L_10_5_χ'_arrow α β 𝔗 𝔎 c aArrDom =
      cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa"
    and [cat_Kan_cs_simps]: "L_10_5_χ'_arrow α β 𝔗 𝔎 c aArrCod =
       L_10_5_N α β 𝔗 𝔎 cObjMapa"
  unfolding L_10_5_χ'_arrow_def arr_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Arrow value›

mk_VLambda L_10_5_χ'_arrow_components(1)
  |vsv L_10_5_χ'_arrow_ArrVal_vsv[cat_Kan_cs_intros]|
  |vdomain L_10_5_χ'_arrow_ArrVal_vdomain|
  |app L_10_5_χ'_arrow_ArrVal_app|

lemma L_10_5_χ'_arrow_ArrVal_vdomain'[cat_Kan_cs_simps]:
  assumes "𝒵 β"
    and "α  β"
    and τ: "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and a: "a  𝔄Obj"
  shows "𝒟 (L_10_5_χ'_arrow α β 𝔗 𝔎 c aArrVal) = Hom
    (cat_Funct α (c CF 𝔎) 𝔄)
    (cf_map (cf_const (c CF 𝔎) 𝔄 a)) 
    (cf_map (𝔗 CF c OCF 𝔎))"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  interpret τ: is_cat_cone α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 τ
    by (rule assms(3))
  from assms(2,4) show ?thesis
    by 
      (
        cs_concl 
          cs_simp: cat_Kan_cs_simps L_10_5_χ'_arrow_ArrVal_vdomain 
          cs_intro: cat_cs_intros
      )
qed

lemma L_10_5_χ'_arrow_ArrVal_app'[cat_cs_simps]:
  assumes "𝒵 β"
    and "α  β"
    and τ'_def: "τ' = ntcf_arrow τ"
    and τ: "τ : a <CF.cone 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    and a: "a  𝔄Obj"
  shows "L_10_5_χ'_arrow α β 𝔗 𝔎 c aArrValτ' =
    ntcf_arrow (L_10_5_υ α 𝔗 𝔎 c τ' a)"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  interpret τ: is_cat_cone α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 τ
    by (rule assms(4))
  from assms(2,5) have "τ'  cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa"
    unfolding τ'_def
    by
      (
        cs_concl
          cs_simp: cat_Kan_cs_simps cat_Funct_components(1)
          cs_intro: cat_small_cs_intros cat_FUNCT_cs_intros cat_cs_intros
      )
  then show
    "L_10_5_χ'_arrow α β 𝔗 𝔎 c aArrValτ' =
      ntcf_arrow (L_10_5_υ α 𝔗 𝔎 c τ' a)"
    unfolding L_10_5_χ'_arrow_components by auto
qed


subsubsectionL_10_5_χ'_arrow› is an isomorphism in the category Set›

lemma L_10_5_χ'_arrow_is_arr_isomorphism: 
  assumes "𝒵 β"
    and "α  β"
    and "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and "a  𝔄Obj"
  shows "L_10_5_χ'_arrow α β 𝔗 𝔎 c a :
    cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa isocat_Set β
    L_10_5_N α β 𝔗 𝔎 cObjMapa" (*FIXME: any reason not to evaluate ObjMap*)
    (
      is 
        ?L_10_5_χ'_arrow :
            cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa isocat_Set β 
            ?L_10_5_NObjMapa
    )
proof-

  let ?FUNCT = λ𝔄. cat_FUNCT α 𝔄 (cat_Set α)
  let ?c𝔎_𝔄 = ‹cat_Funct α (c CF 𝔎) 𝔄
  let ?H_ℭ = λc. HomO.Cα(c,-)
  let ?H_𝔄 = λc. HomO.Cα𝔄(a,-)

  from assms(1,2) interpret β: 𝒵 β by simp 

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(3))
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(4))

  from 𝔎.vempty_is_zet assms interpret c𝔎: tiny_category α c CF 𝔎
    by (cs_concl cs_intro: cat_comma_cs_intros)
  from assms(2,6) interpret c𝔎_𝔄: category α ?c𝔎_𝔄
    by
      (
        cs_concl cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  from 𝔎.vempty_is_zet assms interpret Πc: 
    is_tm_functor α c CF 𝔎 𝔅 c OCF 𝔎
    by (cs_concl cs_intro: cat_comma_cs_intros)

  from assms(2) interpret FUNCT_𝔄: tiny_category β ?FUNCT 𝔄
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  from assms(2) interpret FUNCT_𝔅: tiny_category β ?FUNCT 𝔅
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  from assms(2) interpret FUNCT_ℭ: tiny_category β ?FUNCT 
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  
  have 𝔗Π: "𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦C.tmα 𝔄"
    by (cs_concl cs_intro: cat_small_cs_intros cat_cs_intros)

  from assms(5,6) have [cat_cs_simps]: 
    "cf_of_cf_map (c CF 𝔎) 𝔄 (cf_map (cf_const (c CF 𝔎) 𝔄 a)) =
      cf_const (c CF 𝔎) 𝔄 a"
    "cf_of_cf_map (c CF 𝔎) 𝔄 (cf_map (𝔗 CF c OCF 𝔎)) = 𝔗 CF c OCF 𝔎"
    "cf_of_cf_map 𝔅 (cat_Set α) (cf_map (HomO.Cα(c,-) CF 𝔎)) = 
      HomO.Cα(c,-) CF 𝔎"
    "cf_of_cf_map 𝔅 (cat_Set α) (cf_map (HomO.Cα𝔄(a,-) CF 𝔗)) = 
      HomO.Cα𝔄(a,-) CF 𝔗"
    by (cs_concl cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)+

  note cf_Cone_ObjMap_app = is_tm_functor.cf_Cone_ObjMap_app[OF 𝔗Π assms(1,2,6)]

  show ?thesis
  proof
    (
      intro cat_Set_is_arr_isomorphismI cat_Set_is_arrI arr_SetI, 
      unfold L_10_5_χ'_arrow_components(3) cf_Cone_ObjMap_app
    )
    show "vfsequence ?L_10_5_χ'_arrow" 
      unfolding L_10_5_χ'_arrow_def by auto
    show χ'_arrow_ArrVal_vsv: "vsv (?L_10_5_χ'_arrowArrVal)" 
      unfolding L_10_5_χ'_arrow_components by auto
    show "vcard ?L_10_5_χ'_arrow = 3"
      unfolding L_10_5_χ'_arrow_def by (simp add: nat_omega_simps)
    show [cat_cs_simps]: 
      "𝒟 (?L_10_5_χ'_arrowArrVal) = ?L_10_5_χ'_arrowArrDom"
      unfolding L_10_5_χ'_arrow_components by simp
    show vrange_χ'_arrow_vsubset_N'': 
      " (?L_10_5_χ'_arrowArrVal)  ?L_10_5_NObjMapa"
      unfolding L_10_5_χ'_arrow_components
    proof(rule vrange_VLambda_vsubset)
      fix τ assume prems: "τ  cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa"
      from this assms c𝔎_𝔄.category_axioms have τ_is_arr:
        "τ : cf_map (cf_const (c CF 𝔎) 𝔄 a) ?c𝔎_𝔄 cf_map (𝔗 CF c OCF 𝔎)"
        by
          (
            cs_prems
              cs_simp: cat_cs_simps cat_Kan_cs_simps cat_Funct_components(1)
              cs_intro: cat_small_cs_intros
          )
      note τ = cat_Funct_is_arrD(1,2)[OF τ_is_arr, unfolded cat_cs_simps]
      have "cf_of_cf_map (c CF 𝔎) 𝔄 (cf_map (𝔗 CF c OCF 𝔎)) = 𝔗 CF c OCF 𝔎"
        by (cs_concl cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
      from prems assms τ(1) show 
        "ntcf_arrow (L_10_5_υ α 𝔗 𝔎 c τ a)  ?L_10_5_NObjMapa"
        by (subst τ(2)) (*slow*)
          (
            cs_concl
              cs_simp: cat_cs_simps cat_Kan_cs_simps
              cs_intro: 
                is_cat_coneI cat_cs_intros cat_Kan_cs_intros cat_FUNCT_cs_intros
          )
    qed

    show " (?L_10_5_χ'_arrowArrVal) = ?L_10_5_NObjMapa"
    proof
      (
        intro vsubset_antisym[OF vrange_χ'_arrow_vsubset_N''], 
        intro vsubsetI
      )

      fix υτa assume "υτa  ?L_10_5_NObjMapa"
      from this assms have υτa:
        "υτa : cf_map (?H_ℭ c CF 𝔎) ?FUNCT 𝔅 cf_map (?H_𝔄 a CF 𝔗)"
        by 
          (
            cs_prems 
              cs_simp: cat_cs_simps cat_Kan_cs_simps cs_intro: cat_cs_intros
          )
      note υτa = cat_FUNCT_is_arrD[OF this, unfolded cat_cs_simps]
      interpret τ: 
        is_cat_cone α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ‹L_10_5_τ 𝔗 𝔎 c υτa a
        by (rule L_10_5_τ_is_cat_cone[OF assms(3,4,5) υτa(2,1) assms(6)])

      show "υτa   (?L_10_5_χ'_arrowArrVal)"
      proof(rule vsv.vsv_vimageI2')
        show "vsv (?L_10_5_χ'_arrowArrVal)" by (rule χ'_arrow_ArrVal_vsv)
        from τ.is_cat_cone_axioms assms show
          "ntcf_arrow (L_10_5_τ 𝔗 𝔎 c υτa a)  𝒟 (?L_10_5_χ'_arrowArrVal)"
          by
            (
              cs_concl
                cs_simp: cat_Kan_cs_simps 
                cs_intro: cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
            )
        from assms υτa(1,2) show 
          "υτa = ?L_10_5_χ'_arrowArrValntcf_arrow (L_10_5_τ 𝔗 𝔎 c υτa a)"
          by 
            (
              subst υτa(2), 
              cs_concl_step υτa_def[OF assms(3,4,5) υτa(2,1) assms(6)]  
            )
            (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      qed
    qed

    from assms show "?L_10_5_χ'_arrowArrDom  Vset β"
      by (intro Vset_trans[OF _ Vset_in_mono[OF assms(2)]])
        (
          cs_concl 
            cs_simp: cat_Kan_cs_simps cat_Funct_components(1) cf_Cone_ObjMap_app
            cs_intro: 
              cat_small_cs_intros
              cat_cs_intros
              cat_FUNCT_cs_intros 
              c𝔎_𝔄.cat_Hom_in_Vset
        )
    with assms(2) have "?L_10_5_χ'_arrowArrDom  Vset β"
      by (meson Vset_in_mono Vset_trans)
    from assms show "?L_10_5_NObjMapa  Vset β"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cat_Kan_cs_simps cat_FUNCT_cs_simps 
            cs_intro: cat_cs_intros FUNCT_𝔅.cat_Hom_in_Vset cat_FUNCT_cs_intros
        )
    show dom_χ'_arrow: "𝒟 (?L_10_5_χ'_arrowArrVal) =
      Hom ?c𝔎_𝔄 (cf_map (cf_const (c CF 𝔎) 𝔄 a)) (cf_map (𝔗 CF c OCF 𝔎))"
      unfolding L_10_5_χ'_arrow_components cf_Cone_ObjMap_app by simp
    show "?L_10_5_χ'_arrowArrDom = 
      Hom ?c𝔎_𝔄 (cf_map (cf_const (c CF 𝔎) 𝔄 a)) (cf_map (𝔗 CF c OCF 𝔎))"
      unfolding L_10_5_χ'_arrow_components cf_Cone_ObjMap_app by simp
    show "v11 (?L_10_5_χ'_arrowArrVal)"
    proof(rule vsv.vsv_valeq_v11I, unfold dom_χ'_arrow in_Hom_iff)
      fix τ' τ'' assume prems: 
        "τ' : cf_map (cf_const (c CF 𝔎) 𝔄 a) ?c𝔎_𝔄 cf_map (𝔗 CF c OCF 𝔎)"
        "τ'' : cf_map (cf_const (c CF 𝔎) 𝔄 a) ?c𝔎_𝔄 cf_map (𝔗 CF c OCF 𝔎)"
        "?L_10_5_χ'_arrowArrValτ' = ?L_10_5_χ'_arrowArrValτ''"
      note τ' = cat_Funct_is_arrD[OF prems(1), unfolded cat_cs_simps]
        and τ'' = cat_Funct_is_arrD[OF prems(2), unfolded cat_cs_simps]
      interpret τ': is_cat_cone 
        α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ‹ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ'
        by (rule is_cat_coneI[OF τ'(1) assms(6)])
      interpret τ'': is_cat_cone 
        α a c CF 𝔎 𝔄 𝔗 CF c OCF 𝔎 ‹ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ''
        by (rule is_cat_coneI[OF τ''(1) assms(6)])
      have τ'τ': "ntcf_arrow (ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ') = τ'"
        by (subst (2) τ'(2)) (cs_concl cs_simp: cat_FUNCT_cs_simps)
      have τ''τ'': "ntcf_arrow (ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ'') = τ''"
        by (subst (2) τ''(2)) (cs_concl cs_simp: cat_FUNCT_cs_simps)
      from prems(3) τ'(1) τ''(1) assms have
        "L_10_5_υ α 𝔗 𝔎 c τ' a = L_10_5_υ α 𝔗 𝔎 c τ'' a"
        by (subst (asm) τ'(2), use nothing in subst (asm) τ''(2)) (*slow*)
          (
            cs_prems 
              cs_simp: τ'τ' τ''τ'' cat_cs_simps cat_FUNCT_cs_simps 
              cs_intro: cat_lim_cs_intros cat_Kan_cs_intros cat_cs_intros
          )
      from this have υτ'a_υτ''a: 
        "L_10_5_υ α 𝔗 𝔎 c τ' aNTMapbArrValf =
          L_10_5_υ α 𝔗 𝔎 c τ'' aNTMapbArrValf" 
        if "b  𝔅Obj" and "f : c  (𝔎ObjMapb)" for b f
        by simp
      have [cat_cs_simps]: "τ'NTMap0, b, f = τ''NTMap0, b, f"
        if "b  𝔅Obj" and "f : c  (𝔎ObjMapb)" for b f
        using υτ'a_υτ''a[OF that] that
        by
          (
            cs_prems
              cs_simp: cat_Kan_cs_simps L_10_5_υ_arrow_ArrVal_app
              cs_intro: cat_cs_intros 
          )
      have
        "ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ' =
          ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ''"
      proof(rule ntcf_eqI)
        show "ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ' :
          cf_const (c CF 𝔎) 𝔄 a CF 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
          by (rule τ'.is_ntcf_axioms)
        then have dom_lhs: 
          "𝒟 (ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ'NTMap) = c CF 𝔎Obj"
          by (cs_concl cs_simp: cat_cs_simps)
        show "ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ'' :
          cf_const (c CF 𝔎) 𝔄 a CF 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
          by (rule τ''.is_ntcf_axioms)
        then have dom_rhs: 
          "𝒟 (ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ''NTMap) = c CF 𝔎Obj"
          by (cs_concl cs_simp: cat_cs_simps)
        show
          "ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ'NTMap =
            ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ''NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix A assume "A  c CF 𝔎Obj"
          with assms(5) obtain b f 
            where A_def: "A = [0, b, f]"
              and b: "b  𝔅Obj"
              and f: "f : c  𝔎ObjMapb"
            by auto
          from b f show 
            "ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ'NTMapA =
              ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 τ''NTMapA"
            unfolding A_def 
            by (cs_concl cs_simp: cat_cs_simps cat_FUNCT_cs_simps)
        qed (cs_concl cs_intro: V_cs_intros)+
      qed simp_all
      then show "τ' = τ''"
      proof(rule inj_onD[OF bij_betw_imp_inj_on[OF bij_betw_ntcf_of_ntcf_arrow]])
        show "τ'  ntcf_arrows α (c CF 𝔎) 𝔄"
          by (subst τ'(2))
            (
              cs_concl cs_intro:
                cat_lim_cs_intros cat_cs_intros cat_FUNCT_cs_intros
            )
        show "τ''  ntcf_arrows α (c CF 𝔎) 𝔄"
          by (subst τ''(2))
            (
              cs_concl cs_intro: 
                cat_lim_cs_intros cat_cs_intros cat_FUNCT_cs_intros
            )
      qed
    qed (cs_concl cs_intro: cat_Kan_cs_intros)

  qed auto

qed

lemma L_10_5_χ'_arrow_is_arr_isomorphism'[cat_Kan_cs_intros]: 
  assumes "𝒵 β"
    and "α  β"
    and "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and "a  𝔄Obj" 
    and "A = cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa"
    and "B = L_10_5_N α β 𝔗 𝔎 cObjMapa"
    and "ℭ' = cat_Set β"
  shows "L_10_5_χ'_arrow α β 𝔗 𝔎 c a : A isoℭ' B"
  using assms(1-6)
  unfolding assms(7-9) 
  by (rule L_10_5_χ'_arrow_is_arr_isomorphism)

lemma L_10_5_χ'_arrow_is_arr: 
  assumes "𝒵 β"
    and "α  β"
    and "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and "a  𝔄Obj"
  shows "L_10_5_χ'_arrow α β 𝔗 𝔎 c a :
      cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa cat_Set β
      L_10_5_N α β 𝔗 𝔎 cObjMapa"
    by 
      (
        rule cat_Set_is_arr_isomorphismD(1)[
          OF L_10_5_χ'_arrow_is_arr_isomorphism[OF assms(1-6)]
          ]
      )

lemma L_10_5_χ'_arrow_is_arr'[cat_Kan_cs_intros]: 
  assumes "𝒵 β"
    and "α  β"
    and "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
    and "a  𝔄Obj" 
    and "A = cf_Cone α β (𝔗 CF c OCF 𝔎)ObjMapa"
    and "B = L_10_5_N α β 𝔗 𝔎 cObjMapa"
    and "ℭ' = cat_Set β"
  shows "L_10_5_χ'_arrow α β 𝔗 𝔎 c a : A ℭ' B"
  using assms(1-6) unfolding assms(7-9) by (rule L_10_5_χ'_arrow_is_arr)



subsection‹Lemma X.5: L_10_5_χ›\label{sec:lem_X_5_end}›


subsubsection‹Definition and elementary properties›

definition L_10_5_χ :: "V  V  V  V  V  V"
  where "L_10_5_χ α β 𝔗 𝔎 c =
    [
      (λa𝔗HomCodObj. L_10_5_χ'_arrow α β 𝔗 𝔎 c a),
      cf_Cone α β (𝔗 CF c OCF 𝔎),
      L_10_5_N α β 𝔗 𝔎 c,
      op_cat (𝔗HomCod),
      cat_Set β
    ]"


text‹Components.›

lemma L_10_5_χ_components: 
  shows "L_10_5_χ α β 𝔗 𝔎 cNTMap = 
    (λa𝔗HomCodObj. L_10_5_χ'_arrow α β 𝔗 𝔎 c a)"
    and [cat_Kan_cs_simps]: 
      "L_10_5_χ α β 𝔗 𝔎 cNTDom = cf_Cone α β (𝔗 CF c OCF 𝔎)"
    and [cat_Kan_cs_simps]: 
      "L_10_5_χ α β 𝔗 𝔎 cNTCod = L_10_5_N α β 𝔗 𝔎 c"
    and "L_10_5_χ α β 𝔗 𝔎 cNTDGDom = op_cat (𝔗HomCod)"
    and [cat_Kan_cs_simps]: "L_10_5_χ α β 𝔗 𝔎 cNTDGCod = cat_Set β"
  unfolding L_10_5_χ_def nt_field_simps by (simp_all add: nat_omega_simps)

context
  fixes α 𝔄 𝔅 𝔗
  assumes 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

lemmas L_10_5_χ_components' =
  L_10_5_χ_components[where 𝔗=𝔗, unfolded cat_cs_simps]

lemmas [cat_Kan_cs_simps] = L_10_5_χ_components'(4)

end


subsubsection‹Natural transformation map›

mk_VLambda L_10_5_χ_components(1)
  |vsv L_10_5_χ_NTMap_vsv[cat_Kan_cs_intros]|

context
  fixes α 𝔄 𝔅 𝔗
  assumes 𝔗: "𝔗 : 𝔅 ↦↦Cα 𝔄"
begin

interpretation is_functor α 𝔅 𝔄 𝔗 by (rule 𝔗)

mk_VLambda L_10_5_χ_components(1)[where 𝔗=𝔗, unfolded cat_cs_simps]
  |vdomain L_10_5_χ_NTMap_vdomain[cat_Kan_cs_simps]|
  |app L_10_5_χ_NTMap_app[cat_Kan_cs_simps]|

end


subsubsectionL_10_5_χ› is a natural isomorphism›

lemma L_10_5_χ_is_iso_ntcf:
  ―‹See lemma on page 245 in \cite{mac_lane_categories_2010}.›
  assumes "𝒵 β"
    and "α  β"
    and "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
  shows "L_10_5_χ α β 𝔗 𝔎 c :
    cf_Cone α β (𝔗 CF c OCF 𝔎) CF.iso L_10_5_N α β 𝔗 𝔎 c :
    op_cat 𝔄 ↦↦Cβ cat_Set β"
    (is ?L_10_5_χ : ?cf_Cone CF.iso ?L_10_5_N : op_cat 𝔄 ↦↦Cβ cat_Set β)
proof-

  let ?FUNCT = λ𝔄. cat_FUNCT α 𝔄 (cat_Set α)
  let ?c𝔎_𝔄 = ‹cat_Funct α (c CF 𝔎) 𝔄
  let ?ntcf_c𝔎_𝔄 = ‹ntcf_const (c CF 𝔎) 𝔄
  let ?𝔗_c𝔎 = 𝔗 CF c OCF 𝔎
  let ?H_ℭ = λc. HomO.Cα(c,-)
  let ?H_𝔄 = λa. HomO.Cα𝔄(a,-)
  let ?L_10_5_χ'_arrow = ‹L_10_5_χ'_arrow α β 𝔗 𝔎 c
  let ?cf_c𝔎_𝔄 = ‹cf_const (c CF 𝔎) 𝔄
  let ?L_10_5_υ = ‹L_10_5_υ α 𝔗 𝔎 c
  let ?L_10_5_υ_arrow = ‹L_10_5_υ_arrow 𝔗 𝔎 c

  interpret β: 𝒵 β by (rule assms(1))

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(3))
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(4))

  from 𝔎.vempty_is_zet assms(5) interpret c𝔎: tiny_category α c CF 𝔎
    by (cs_concl cs_intro: cat_comma_cs_intros)
  from assms(2,5) interpret c𝔎_𝔄: category α ?c𝔎_𝔄
    by
      (
        cs_concl cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  interpret β_c𝔎_𝔄: category β ?c𝔎_𝔄
    by (rule c𝔎_𝔄.cat_category_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros assms(2))+
  from assms(2,5) interpret Δ: is_functor α 𝔄 ?c𝔎_𝔄 ΔC α (c CF 𝔎) 𝔄
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms assms(2) interpret βΔ: 
    is_functor β 𝔄 ?c𝔎_𝔄 ΔC α (c CF 𝔎) 𝔄
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from 𝔎.vempty_is_zet assms(5) interpret Πc: 
    is_tm_functor α c CF 𝔎 𝔅 c OCF 𝔎
    by
      (
        cs_concl
          cs_simp: cat_comma_cs_simps 
          cs_intro: cat_small_cs_intros cat_cs_intros cat_comma_cs_intros
      )
  interpret βΠc: is_tiny_functor β c CF 𝔎 𝔅 c OCF 𝔎
    by (rule Πc.cf_is_tiny_functor_if_ge_Limit[OF assms(1,2)])
  
  interpret E: is_functor β ?FUNCT  ×C  ‹cat_Set β ‹cf_eval α β 
    by (rule 𝔎.HomCod.cat_cf_eval_is_functor[OF assms(1,2)])

  from assms(2) interpret FUNCT_𝔄: tiny_category β ?FUNCT 𝔄
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  from assms(2) interpret FUNCT_𝔅: tiny_category β ?FUNCT 𝔅
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  from assms(2) interpret FUNCT_ℭ: tiny_category β ?FUNCT 
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  
  interpret β𝔄: tiny_category β 𝔄
    by (rule category.cat_tiny_category_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+
  interpret β𝔅: tiny_category β 𝔅
    by (rule category.cat_tiny_category_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+
  interpret βℭ: tiny_category β 
    by (rule category.cat_tiny_category_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+

  interpret β𝔎: is_tiny_functor β 𝔅  𝔎
    by (rule is_functor.cf_is_tiny_functor_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+
  interpret β𝔗: is_tiny_functor β 𝔅 𝔄 𝔗
    by (rule is_functor.cf_is_tiny_functor_if_ge_Limit)
      (use assms(2) in cs_concl cs_simp: cs_intro: cat_cs_intros)+

  interpret cat_Set_αβ: subcategory β ‹cat_Set α ‹cat_Set β
    by (rule 𝔎.subcategory_cat_Set_cat_Set[OF assms(1,2)])
  
  show ?thesis
  proof(intro is_iso_ntcfI is_ntcfI', unfold cat_op_simps)

    show "vfsequence (?L_10_5_χ)" unfolding L_10_5_χ_def by auto
    show "vcard (?L_10_5_χ) = 5" 
      unfolding L_10_5_χ_def by (simp add: nat_omega_simps)
    from assms(2) show "?cf_Cone : op_cat 𝔄 ↦↦Cβ cat_Set β" 
      by (intro is_tm_functor.tm_cf_cf_Cone_is_functor_if_ge_Limit)
        (cs_concl cs_intro: cat_small_cs_intros cat_cs_intros)+

    from assms show "?L_10_5_N : op_cat 𝔄 ↦↦Cβ cat_Set β" 
      by (cs_concl cs_intro: cat_Kan_cs_intros)
    show "?L_10_5_χNTMapa : 
      ?cf_ConeObjMapa isocat_Set β ?L_10_5_NObjMapa"
      if "a  𝔄Obj" for a 
      using assms(2,3,4,5) that
      by
        (
          cs_concl 
            cs_simp: L_10_5_χ_NTMap_app 
            cs_intro: cat_cs_intros L_10_5_χ'_arrow_is_arr_isomorphism
         )
    from cat_Set_is_arr_isomorphismD[OF this] show 
      "?L_10_5_χNTMapa : ?cf_ConeObjMapa cat_Set β ?L_10_5_NObjMapa"
      if "a  𝔄Obj" for a
      using that by auto

    have [cat_cs_simps]:
      "?L_10_5_χ'_arrow b Acat_Set β
        cf_hom ?c𝔎_𝔄 [ntcf_arrow (?ntcf_c𝔎_𝔄 f), ntcf_arrow (ntcf_id ?𝔗_c𝔎)] =
        cf_hom (?FUNCT 𝔅)
          [
            ntcf_arrow (ntcf_id (?H_ℭ c CF 𝔎)),
            ntcf_arrow (HomA.Cα𝔄(f,-) NTCF-CF 𝔗)
          ] Acat_Set β ?L_10_5_χ'_arrow a"
      (
        is 
          "?L_10_5_χ'_arrow b Acat_Set β ?cf_hom_lhs =
            ?cf_hom_rhs Acat_Set β ?L_10_5_χ'_arrow a"
      )
      if "f : b 𝔄 a" for a b f
    proof-
      let ?H_f = HomA.Cα𝔄(f,-)
      from that assms β_c𝔎_𝔄.category_axioms c𝔎_𝔄.category_axioms have lhs:
        "?L_10_5_χ'_arrow b Acat_Set β ?cf_hom_lhs :
          Hom ?c𝔎_𝔄 (cf_map (?cf_c𝔎_𝔄 a)) (cf_map ?𝔗_c𝔎) cat_Set β
          ?L_10_5_NObjMapb"
        by (*slow*)
          (
            cs_concl
              cs_simp:
                cat_Kan_cs_simps
                cat_cs_simps
                cat_FUNCT_cs_simps
                cat_Funct_components(1)
                cat_op_simps
              cs_intro:
                cat_Kan_cs_intros
                cat_small_cs_intros
                cat_FUNCT_cs_intros
                cat_cs_intros
                cat_prod_cs_intros
                cat_op_intros
          )
      then have dom_lhs:
        "𝒟 ((?L_10_5_χ'_arrow b Acat_Set β ?cf_hom_lhs)ArrVal) =
          Hom ?c𝔎_𝔄 (cf_map (?cf_c𝔎_𝔄 a)) (cf_map ?𝔗_c𝔎)"
        by (cs_concl cs_simp: cat_cs_simps)
      from that assms β_c𝔎_𝔄.category_axioms c𝔎_𝔄.category_axioms have rhs:
        "?cf_hom_rhs Acat_Set β ?L_10_5_χ'_arrow a :
          Hom ?c𝔎_𝔄 (cf_map (?cf_c𝔎_𝔄 a)) (cf_map ?𝔗_c𝔎) cat_Set β
          ?L_10_5_NObjMapb"
        by (*slow*)
          (
            cs_concl
              cs_simp: 
                cat_Kan_cs_simps 
                cat_cs_simps
                cat_Funct_components(1)
                cat_op_simps
              cs_intro:
                cat_Kan_cs_intros
                cat_small_cs_intros
                cat_cs_intros
                cat_prod_cs_intros
                cat_FUNCT_cs_intros
                cat_op_intros
          )
      then have dom_rhs:
        "𝒟 ((?cf_hom_rhs Acat_Set β ?L_10_5_χ'_arrow a)ArrVal) =
          Hom ?c𝔎_𝔄 (cf_map (?cf_c𝔎_𝔄 a)) (cf_map ?𝔗_c𝔎)"
        by (cs_concl cs_simp: cat_cs_simps)

      show ?thesis
      proof(rule arr_Set_eqI)
        from lhs show arr_Set_lhs: 
          "arr_Set β (?L_10_5_χ'_arrow b Acat_Set β ?cf_hom_lhs)"
          by (auto dest: cat_Set_is_arrD(1))
        from rhs show arr_Set_rhs:
          "arr_Set β (?cf_hom_rhs Acat_Set β ?L_10_5_χ'_arrow a)"
          by (auto dest: cat_Set_is_arrD(1))
        show 
          "(?L_10_5_χ'_arrow b Acat_Set β ?cf_hom_lhs)ArrVal =
            (?cf_hom_rhs Acat_Set β ?L_10_5_χ'_arrow a)ArrVal"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
          fix F assume prems: "F : cf_map (?cf_c𝔎_𝔄 a) ?c𝔎_𝔄 cf_map ?𝔗_c𝔎"
          let ?F = ‹ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 F
          from that have [cat_cs_simps]:
            "cf_of_cf_map (c CF 𝔎) 𝔄 (cf_map (?cf_c𝔎_𝔄 a)) = ?cf_c𝔎_𝔄 a"
            "cf_of_cf_map (c CF 𝔎) 𝔄 (cf_map (?𝔗_c𝔎)) = ?𝔗_c𝔎"
            by (cs_concl cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
          note F = cat_Funct_is_arrD[OF prems, unfolded cat_cs_simps]
          from that F(1) have F_const_is_cat_cone:
            "?F NTCF ?ntcf_c𝔎_𝔄 f : b <CF.cone ?𝔗_c𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
            by
              (
                cs_concl
                  cs_simp: cat_cs_simps
                  cs_intro: cat_small_cs_intros is_cat_coneI cat_cs_intros
              )
          have [cat_cs_simps]:
            "?L_10_5_υ (ntcf_arrow (?F NTCF ?ntcf_c𝔎_𝔄 f)) b =
              ?H_f NTCF-CF 𝔗 NTCF ?L_10_5_υ (ntcf_arrow ?F) a"
          proof(rule ntcf_eqI)
            from assms that F(1) show
              "?L_10_5_υ (ntcf_arrow (?F NTCF ?ntcf_c𝔎_𝔄 f)) b :
                ?H_ℭ c CF 𝔎 CF ?H_𝔄 b CF 𝔗 : 𝔅 ↦↦Cα cat_Set α"
              by
                (
                  cs_concl cs_intro:
                    cat_small_cs_intros 
                    cat_Kan_cs_intros 
                    cat_cs_intros 
                    is_cat_coneI
                )
            then have dom_υ: 
              "𝒟 (?L_10_5_υ (ntcf_arrow (?F NTCF ?ntcf_c𝔎_𝔄 f)) bNTMap) = 
                𝔅Obj"
              by (cs_concl cs_simp: cat_cs_simps)
            from assms that F(1) show 
              "?H_f NTCF-CF 𝔗 NTCF ?L_10_5_υ (ntcf_arrow ?F) a :
                ?H_ℭ c CF 𝔎 CF ?H_𝔄 b CF 𝔗 : 𝔅 ↦↦Cα cat_Set α"
              by
                (
                  cs_concl cs_intro:
                    cat_Kan_cs_intros cat_cs_intros is_cat_coneI
                )
            then have dom_f𝔗υ:
              "𝒟 ((?H_f NTCF-CF 𝔗 NTCF ?L_10_5_υ (ntcf_arrow ?F) a)NTMap) =
                𝔅Obj"
              by (cs_concl cs_simp: cat_cs_simps)
            show 
              "?L_10_5_υ (ntcf_arrow (?F NTCF ?ntcf_c𝔎_𝔄 f)) bNTMap =
                (?H_f NTCF-CF 𝔗 NTCF ?L_10_5_υ (ntcf_arrow ?F) a)NTMap"
            proof(rule vsv_eqI, unfold dom_υ dom_f𝔗υ)
              fix b' assume prems': "b'  𝔅Obj"
              let ?Y = ‹Yoneda_component (?H_𝔄 b) a f (𝔗ObjMapb')
              let ?𝔎b' = 𝔎ObjMapb'
              let ?𝔗b' = 𝔗ObjMapb'
              have [cat_cs_simps]:
                "?L_10_5_υ_arrow (ntcf_arrow (?F NTCF ?ntcf_c𝔎_𝔄 f)) b b' =
                  ?Y Acat_Set α ?L_10_5_υ_arrow (ntcf_arrow ?F) a b'"
                (is ?υ_Ffbb' = ?Yυ)
              proof-
                from assms prems' F_const_is_cat_cone have υ_Ffbb': 
                  "?υ_Ffbb' : Hom  c ?𝔎b' cat_Set α Hom 𝔄 b ?𝔗b'"
                  by 
                    (
                      cs_concl cs_intro:
                        cat_cs_intros L_10_5_υ_arrow_is_arr
                    )
                then have dom_υ_Ffbb': "𝒟 (?υ_Ffbb'ArrVal) = Hom  c (?𝔎b')"
                  by (cs_concl cs_simp: cat_cs_simps)
                from assms that 𝔗.HomCod.category_axioms prems' F(1) have:
                  "?Yυ : Hom  c ?𝔎b' cat_Set α Hom 𝔄 b ?𝔗b'"
                  by
                    (
                      cs_concl
                        cs_simp: cat_Kan_cs_simps cat_cs_simps cat_op_simps
                        cs_intro: is_cat_coneI cat_Kan_cs_intros cat_cs_intros
                    )
                then have dom_Yυ: "𝒟 (?YυArrVal) = Hom  c (?𝔎b')"
                  by (cs_concl cs_simp: cat_cs_simps)
                show ?thesis
                proof(rule arr_Set_eqI)
                  from υ_Ffbb' show arr_Set_υ_Ffbb': "arr_Set α ?υ_Ffbb'"
                    by (auto dest: cat_Set_is_arrD(1))
                  fromshow arr_Set_Yυ: "arr_Set α ?Yυ"
                    by (auto dest: cat_Set_is_arrD(1))
                  show "?υ_Ffbb'ArrVal = ?YυArrVal"
                  proof(rule vsv_eqI, unfold dom_υ_Ffbb' dom_Yυ in_Hom_iff)
                    fix g assume "g : c  ?𝔎b'"
                    with 
                      assms(2-) 
                      𝔎.is_functor_axioms 
                      𝔗.is_functor_axioms 
                      𝔗.HomCod.category_axioms 
                      𝔎.HomCod.category_axioms 
                      that prems' F(1) 
                    show "?υ_Ffbb'ArrValg = ?YυArrValg"
                      by (*slow*)
                        (
                          cs_concl
                            cs_simp:
                              cat_Kan_cs_simps
                              cat_cs_simps
                              L_10_5_υ_arrow_ArrVal_app
                              cat_comma_cs_simps
                              cat_op_simps
                            cs_intro: 
                              cat_Kan_cs_intros 
                              is_cat_coneI 
                              cat_cs_intros 
                              cat_comma_cs_intros
                              cat_op_intros 
                            cs_simp: cat_FUNCT_cs_simps
                            cs_intro: cat_small_cs_intros
                        )
                  qed (use arr_Set_υ_Ffbb' arr_Set_Yυ in auto)
                qed (use υ_Ffbb' Yυ in cs_concl cs_simp: cat_cs_simps)+
              qed

              from assms prems' that F(1) show
                "?L_10_5_υ (ntcf_arrow (?F NTCF ?ntcf_c𝔎_𝔄 f)) bNTMapb' =
                  (?H_f NTCF-CF 𝔗 NTCF ?L_10_5_υ (ntcf_arrow ?F) a)NTMapb'"
                by
                  (
                    cs_concl
                      cs_simp: cat_Kan_cs_simps cat_cs_simps
                      cs_intro: is_cat_coneI cat_Kan_cs_intros cat_cs_intros
                  )

            qed (cs_concl cs_intro: cat_Kan_cs_intros cat_cs_intros)+

          qed simp_all

          from that F(1) interpret F: is_cat_cone α a c CF 𝔎 𝔄 ?𝔗_c𝔎 ?F
            by (cs_concl cs_intro: is_cat_coneI cat_cs_intros)
          from
            assms(2-) prems F(1) that
            𝔗.HomCod.cat_ntcf_Hom_snd_is_ntcf[OF that] (*speedup*)
            β_c𝔎_𝔄.category_axioms (*speedup*)
          show 
            "(?L_10_5_χ'_arrow b Acat_Set β ?cf_hom_lhs)ArrValF =
              (?cf_hom_rhs Acat_Set β ?L_10_5_χ'_arrow a)ArrValF"
            by (subst (1 2) F(2)) (*exceptionally slow*)
            (
              cs_concl
                cs_simp: 
                  cat_cs_simps 
                  cat_Kan_cs_simps
                  cat_FUNCT_cs_simps 
                  cat_Funct_components(1) 
                  cat_op_simps 
                cs_intro: 
                  cat_small_cs_intros 
                  is_cat_coneI 
                  cat_Kan_cs_intros
                  cat_cs_intros 
                  cat_prod_cs_intros 
                  cat_FUNCT_cs_intros 
                  cat_op_intros
            )
        qed (use arr_Set_lhs arr_Set_rhs in auto)

      qed (use lhs rhs in cs_concl cs_simp: cat_cs_simps)+

    qed

    show 
      "?L_10_5_χNTMapb Acat_Set β ?cf_ConeArrMapf =
        ?L_10_5_NArrMapf Acat_Set β ?L_10_5_χNTMapa"
      if "f : b 𝔄 a" for a b f
      using that assms
      by
        (
          cs_concl
            cs_simp:
              cat_cs_simps
              cat_Kan_cs_simps
              cat_Funct_components(1)
              cat_FUNCT_cs_simps
              cat_op_simps
            cs_intro: 
              cat_small_cs_intros
              cat_Kan_cs_intros
              cat_cs_intros
              cat_FUNCT_cs_intros
              cat_op_intros
        )

  qed 
    (
      cs_concl
        cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed



subsection‹
The limit of 𝔗 ∘CF c OCF 𝔎› exists for every 
pointwise right Kan extension of 𝔗› along 𝔎›

lemma (in is_cat_pw_rKe) cat_pw_rKe_ex_cat_limit:
  ―‹Based on the elements of Chapter X-5 in \cite{mac_lane_categories_2010}.
    The size conditions for the functors 𝔎› and 𝔗› are related to the
    choice of the definition of the limit in this work (by definition,
    all limits are small).›
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
  obtains UA 
    where "UA : 𝔊ObjMapc <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
proof-

  define β where "β = α + ω"
  have β: "𝒵 β" and αβ: "α  β" 
    by (simp_all add: β_def AG.𝒵_Limit_αω AG.𝒵_ω_αω 𝒵_def AG.𝒵_α_αω)
  then interpret β: 𝒵 β by simp 

  let ?FUNCT = λ𝔄. cat_FUNCT α 𝔄 (cat_Set α)
  let ?H_A = λf. HomA.Cα𝔄(f,-)
  let ?H_A𝔊 = λf. ?H_A f NTCF-CF 𝔊
  let ?H_𝔄 = λa. HomO.Cα𝔄(a,-)
  let ?H_𝔄𝔗 = λa. ?H_𝔄 a CF 𝔗
  let ?H_𝔄𝔊 = λa. ?H_𝔄 a CF 𝔊
  let ?H_ℭ = λc. HomO.Cα(c,-)
  let ?H_ℭ𝔎 = λc. ?H_ℭ c CF 𝔎
  let ?H_𝔄ε = λb. ?H_𝔄 b CF-NTCF ε
  let ?SET_𝔎 = ‹exp_cat_cf α (cat_Set α) 𝔎
  let ?H_FUNCT = λ 𝔉. HomO.Cβ?FUNCT (-,cf_map 𝔉)
  let ?ua_NTDGDom = ‹op_cat (?FUNCT )
  let ?ua_NTDom = λa. ?H_FUNCT  (?H_𝔄𝔊 a)
  let ?ua_NTCod = λa. ?H_FUNCT 𝔅 (?H_𝔄𝔗 a) CF op_cf ?SET_𝔎
  let ?c𝔎_𝔄 = ‹cat_Funct α (c CF 𝔎) 𝔄
  let ?ua = 
    λa. ntcf_ua_fo
        β
        ?SET_𝔎
        (cf_map (?H_𝔄𝔗 a))
        (cf_map (?H_𝔄𝔊 a))
        (ntcf_arrow (?H_𝔄ε a))
  let ?cf_nt = ‹cf_nt α β (cf_id )
  let ?cf_eval = ‹cf_eval α β 
  let ?𝔗_c𝔎 = 𝔗 CF c OCF 𝔎
  let ?cf_c𝔎_𝔄 = ‹cf_const (c CF 𝔎) 𝔄
  let ?𝔊c = 𝔊ObjMapc
  let  = ΔC α (c CF 𝔎) 𝔄
  let ?ntcf_ua_fo = 
    λa. ntcf_ua_fo
        β 
        ?SET_𝔎 
        (cf_map (?H_𝔄𝔗 a)) 
        (cf_map (?H_𝔄𝔊 a)) 
        (ntcf_arrow (?H_𝔄ε a))
  let ?umap_fo =
    λb. umap_fo
        ?SET_𝔎
        (cf_map (?H_𝔄𝔗 b))
        (cf_map (?H_𝔄𝔊 b))
        (ntcf_arrow (?H_𝔄ε b))
        (cf_map (?H_ℭ c))

  interpret 𝔎: is_tm_functor α 𝔅  𝔎 by (rule assms(1))
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(2))

  from AG.vempty_is_zet assms(3) interpret c𝔎: tiny_category α c CF 𝔎
    by (cs_concl cs_intro: cat_comma_cs_intros)
  from αβ assms(3) interpret c𝔎_𝔄: category α ?c𝔎_𝔄
    by
      (
        cs_concl cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  interpret β_c𝔎_𝔄: category β ?c𝔎_𝔄
    by (rule c𝔎_𝔄.cat_category_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros αβ)+
  from αβ assms(3) interpret Δ: is_functor α 𝔄 ?c𝔎_𝔄 
    by
      (
        cs_concl cs_intro: 
          cat_small_cs_intros cat_cs_intros cat_op_intros
      )+
  from Δ.is_functor_axioms αβ interpret βΔ: 
    is_functor β 𝔄 ?c𝔎_𝔄 
    by (cs_intro_step is_functor.cf_is_functor_if_ge_Limit)
      (cs_concl cs_intro: cat_cs_intros)+
  from AG.vempty_is_zet assms(3) interpret Πc: 
    is_tm_functor α c CF 𝔎 𝔅 c OCF 𝔎
    by
      (
        cs_concl
          cs_simp: cat_comma_cs_simps 
          cs_intro: cat_small_cs_intros cat_cs_intros cat_comma_cs_intros
      )
  interpret βΠc: is_tiny_functor β c CF 𝔎 𝔅 c OCF 𝔎
    by (rule Πc.cf_is_tiny_functor_if_ge_Limit[OF β αβ])
  
  interpret E: is_functor β ?FUNCT  ×C  ‹cat_Set β ?cf_eval
    by (rule AG.HomCod.cat_cf_eval_is_functor[OF β αβ])

  from αβ interpret FUNCT_𝔄: tiny_category β ?FUNCT 𝔄
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  from αβ interpret FUNCT_𝔅: tiny_category β ?FUNCT 𝔅
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  from αβ interpret FUNCT_ℭ: tiny_category β ?FUNCT 
    by (cs_concl cs_intro: cat_cs_intros cat_FUNCT_cs_intros)
  
  interpret β𝔄: tiny_category β 𝔄
    by (rule category.cat_tiny_category_if_ge_Limit)
      (use αβ in cs_concl cs_intro: cat_cs_intros)+
  interpret β𝔅: tiny_category β 𝔅
    by (rule category.cat_tiny_category_if_ge_Limit)
      (use αβ in cs_concl cs_intro: cat_cs_intros)+
  interpret βℭ: tiny_category β 
    by (rule category.cat_tiny_category_if_ge_Limit)
      (use αβ in cs_concl cs_intro: cat_cs_intros)+

  interpret β𝔎: is_tiny_functor β 𝔅  𝔎
    by (rule is_functor.cf_is_tiny_functor_if_ge_Limit)
      (use αβ in cs_concl cs_intro: cat_cs_intros)+
  interpret β𝔊: is_tiny_functor β  𝔄 𝔊
    by (rule is_functor.cf_is_tiny_functor_if_ge_Limit)
      (use αβ in cs_concl cs_intro: cat_cs_intros)+
  interpret β𝔗: is_tiny_functor β 𝔅 𝔄 𝔗
    by (rule is_functor.cf_is_tiny_functor_if_ge_Limit)
      (use αβ in cs_concl cs_intro: cat_cs_intros)+

  interpret cat_Set_αβ: subcategory β ‹cat_Set α ‹cat_Set β
    by (rule AG.subcategory_cat_Set_cat_Set[OF β αβ])

  from assms(3) αβ interpret Hom_c: is_functor α  ‹cat_Set α ?H_ℭ c 
    by (cs_concl cs_intro: cat_cs_intros)

  (** E' **)

  define E' :: V where "E' =
    [
      (λa𝔄Obj. ?cf_evalObjMapcf_map (?H_𝔄𝔊 a), c),
      (λf𝔄Arr. ?cf_evalArrMapntcf_arrow (?H_A𝔊 f), CIdc),
      op_cat 𝔄,
      cat_Set β
    ] "

  have E'_components:
    "E'ObjMap = (λa𝔄Obj. ?cf_evalObjMapcf_map (?H_𝔄𝔊 a), c)"
    "E'ArrMap =
      (λf𝔄Arr. ?cf_evalArrMapntcf_arrow (?H_A𝔊 f), CIdc)"
    "E'HomDom = op_cat 𝔄"
    "E'HomCod = cat_Set β"
    unfolding E'_def dghm_field_simps by (simp_all add: nat_omega_simps)

  note [cat_cs_simps] = E'_components(3,4)
  
  have E'_ObjMap_app[cat_cs_simps]: 
    "E'ObjMapa = ?cf_evalObjMapcf_map (?H_𝔄𝔊 a), c"
    if "a  𝔄Obj" for a
    using that unfolding E'_components by simp
  have E'_ArrMap_app[cat_cs_simps]: 
    "E'ArrMapf = ?cf_evalArrMapntcf_arrow (?H_A𝔊 f), CIdc"
    if "f  𝔄Arr" for f
    using that unfolding E'_components by simp

  have E': "E' : op_cat 𝔄 ↦↦Cβ cat_Set β"
  proof(intro is_functorI')

    show "vfsequence E'" unfolding E'_def by auto
    show "vcard E' = 4" unfolding E'_def by (simp add: nat_omega_simps)
    show "vsv (E'ObjMap)" unfolding E'_components by simp
    show "vsv (E'ArrMap)" unfolding E'_components by simp
    show "𝒟 (E'ObjMap) = op_cat 𝔄Obj"
      unfolding E'_components by (simp add: cat_op_simps)
    show " (E'ObjMap)  cat_Set βObj"
      unfolding E'_components
    proof(rule vrange_VLambda_vsubset)
      fix a assume prems: "a  𝔄Obj"
      then have "?H_𝔄𝔊 a :  ↦↦Cα cat_Set α"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      with assms(3) prems show 
        "?cf_evalObjMapcf_map (?H_𝔄𝔊 a), c  cat_Set βObj"
        by 
          (
            cs_concl
              cs_simp: cat_cs_simps cat_Set_components(1)
              cs_intro: cat_cs_intros cat_op_intros Ran.HomCod.cat_Hom_in_Vset
          )
    qed
    show "𝒟 (E'ArrMap) = op_cat 𝔄Arr"
      unfolding E'_components by (simp add: cat_op_simps)
    show "E'ArrMapf : E'ObjMapa cat_Set β E'ObjMapb"
      if "f : a op_cat 𝔄 b" for a b f
    proof-
      from that[unfolded cat_op_simps] assms(3) show ?thesis
        by (intro cat_Set_αβ.subcat_is_arrD)
          (
            cs_concl 
              cs_simp:
                category.cf_eval_ObjMap_app
                category.cf_eval_ArrMap_app
                E'_ObjMap_app
                E'_ArrMap_app
              cs_intro: cat_cs_intros
          )
    qed
    then have [cat_cs_intros]: "E'ArrMapf : A cat_Set β B"
      if "A = E'ObjMapa" and "B = E'ObjMapb" and "f : b 𝔄 a" 
      for a b f A B
      using that by (simp add: cat_op_simps)
    show
      "E'ArrMapg Aop_cat 𝔄 f = E'ArrMapg Acat_Set β E'ArrMapf"
      if "g : b op_cat 𝔄 c" and "f : a op_cat 𝔄 b" for b c g a f
    proof-
      note g = that(1)[unfolded cat_op_simps]
        and f = that(2)[unfolded cat_op_simps]
      from g f assms(3) αβ show ?thesis
        by 
          (
            cs_concl
              cs_intro:
                cat_small_cs_intros
                cat_cs_intros
                cat_prod_cs_intros
                cat_FUNCT_cs_intros 
                cat_op_intros
              cs_simp:
                cat_cs_simps
                cat_FUNCT_cs_simps 
                cat_prod_cs_simps 
                cat_op_simps
                E.cf_ArrMap_Comp[symmetric]
          )+
    qed
    
    show "E'ArrMapop_cat 𝔄CIda = cat_Set βCIdE'ObjMapa"
      if "a  op_cat 𝔄Obj" for a
    proof(cs_concl_step cat_Set_αβ.subcat_CId[symmetric])
      from that[unfolded cat_op_simps] assms(3) show 
        "E'ObjMapa  cat_Set αObj"
        by 
          (
            cs_concl 
              cs_simp: cat_Set_components(1) cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros
          )
      from that[unfolded cat_op_simps] assms(3) show 
        "E'ArrMapop_cat 𝔄CIda = cat_Set αCIdE'ObjMapa"
        by
          (
            cs_concl 
              cs_intro: cat_cs_intros
              cs_simp:
                cat_Set_components(1)
                cat_cs_simps
                cat_op_simps
                ntcf_id_cf_comp[symmetric]
          )
    qed
  qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+
  then interpret E': is_functor β ‹op_cat 𝔄 ‹cat_Set β E' by simp


  (** N' **)

  define N' :: V where "N' =
    [
      (λa𝔄Obj. ?cf_ntObjMapcf_map (?H_𝔄𝔊 a), c),
      (λf𝔄Arr. ?cf_ntArrMapntcf_arrow (?H_A𝔊 f), CIdc),
      op_cat 𝔄,
      cat_Set β
    ] "

  have N'_components:
    "N'ObjMap = (λa𝔄Obj. ?cf_ntObjMapcf_map (?H_𝔄𝔊 a), c)"
    "N'ArrMap =
      (λf𝔄Arr. ?cf_ntArrMapntcf_arrow (?H_A𝔊 f), CIdc)"
    "N'HomDom = op_cat 𝔄"
    "N'HomCod = cat_Set β"
    unfolding N'_def dghm_field_simps by (simp_all add: nat_omega_simps)

  note [cat_cs_simps] = N'_components(3,4)
  
  have N'_ObjMap_app[cat_cs_simps]: 
    "N'ObjMapa = ?cf_ntObjMapcf_map (?H_𝔄𝔊 a), c"
    if "a  𝔄Obj" for a
    using that unfolding N'_components by simp
  have N'_ArrMap_app[cat_cs_simps]: 
    "N'ArrMapf = ?cf_ntArrMapntcf_arrow (?H_A𝔊 f), CIdc"
    if "f  𝔄Arr" for f
    using that unfolding N'_components by simp

  from αβ interpret cf_nt_ℭ: is_functor β ?FUNCT  ×C  ‹cat_Set β ?cf_nt
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  
  have N': "N' : op_cat 𝔄 ↦↦Cβ cat_Set β"
  proof(intro is_functorI')
    show "vfsequence N'" unfolding N'_def by simp
    show "vcard N' = 4" unfolding N'_def by (simp add: nat_omega_simps)
    show "vsv (N'ObjMap)" unfolding N'_components by simp
    show "vsv (N'ArrMap)" unfolding N'_components by simp
    show "𝒟 (N'ObjMap) = op_cat 𝔄Obj"
      unfolding N'_components by (simp add: cat_op_simps)
    show " (N'ObjMap)  cat_Set βObj"
      unfolding N'_components
    proof(rule vrange_VLambda_vsubset)
      fix a assume prems: "a  𝔄Obj"
      with assms(3) αβ show 
        "?cf_ntObjMapcf_map (?H_𝔄𝔊 a), c  cat_Set βObj"
        by 
          (
            cs_concl 
              cs_simp: cat_Set_components(1) cat_cs_simps cat_FUNCT_cs_simps  
              cs_intro: cat_cs_intros FUNCT_ℭ.cat_Hom_in_Vset cat_FUNCT_cs_intros
          )
    qed
    show "𝒟 (N'ArrMap) = op_cat 𝔄Arr" 
      unfolding N'_components by (simp add: cat_op_simps)
    show "N'ArrMapf : N'ObjMapa cat_Set β N'ObjMapb"
      if "f : a op_cat 𝔄 b" for a b f
      using that[unfolded cat_op_simps] assms(3)
      by 
        (
          cs_concl 
            cs_simp: N'_ObjMap_app N'_ArrMap_app 
            cs_intro: cat_cs_intros cat_prod_cs_intros cat_FUNCT_cs_intros
        )
    show 
      "N'ArrMapg Aop_cat 𝔄 f = N'ArrMapg Acat_Set β N'ArrMapf"
      if "g : b op_cat 𝔄 c" and "f : a op_cat 𝔄 b" for b c g a f
    proof-
      from that assms(3) αβ show ?thesis
        unfolding cat_op_simps
        by
          (
            cs_concl
              cs_intro:
                cat_cs_intros
                cat_prod_cs_intros
                cat_FUNCT_cs_intros 
                cat_op_intros
              cs_simp:
                cat_cs_simps
                cat_FUNCT_cs_simps 
                cat_prod_cs_simps 
                cat_op_simps
                cf_nt_ℭ.cf_ArrMap_Comp[symmetric]
          )
    qed
    show "N'ArrMapop_cat 𝔄CIda = cat_Set βCIdN'ObjMapa"
      if "a  op_cat 𝔄Obj" for a
    proof-
      note [cat_cs_simps] = 
        ntcf_id_cf_comp[symmetric] 
        ntcf_arrow_id_ntcf_id[symmetric]
        cat_FUNCT_CId_app[symmetric] 
      from that[unfolded cat_op_simps] assms(3) αβ show ?thesis
        by (*very slow*)
          (
            cs_concl
              cs_intro:
                cat_cs_intros
                cat_FUNCT_cs_intros
                cat_prod_cs_intros
                cat_op_intros
              cs_simp: cat_FUNCT_cs_simps cat_cs_simps cat_op_simps 
          )+
    qed
  qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+
  then interpret N': is_functor β ‹op_cat 𝔄 ‹cat_Set β N' by simp


  (** Y' **)
  
  define Y' :: V where "Y' =
    [
      (λa𝔄Obj. ntcf_Yoneda α β NTMapcf_map (?H_𝔄𝔊 a), c),
      N',
      E',
      op_cat 𝔄,
      cat_Set β
    ]"

  have Y'_components:
    "Y'NTMap = (λa𝔄Obj. ntcf_Yoneda α β NTMapcf_map (?H_𝔄𝔊 a), c)"
    "Y'NTDom = N'"
    "Y'NTCod = E'"
    "Y'NTDGDom = op_cat 𝔄"
    "Y'NTDGCod = cat_Set β"
    unfolding Y'_def nt_field_simps by (simp_all add: nat_omega_simps)

  note [cat_cs_simps] = Y'_components(2-5)

  have Y'_NTMap_app[cat_cs_simps]: 
    "Y'NTMapa = ntcf_Yoneda α β NTMapcf_map (?H_𝔄𝔊 a), c" 
    if "a  𝔄Obj" for a
    using that unfolding Y'_components by simp

  from β αβ interpret Y: 
    is_iso_ntcf β ?FUNCT  ×C  ‹cat_Set β ?cf_nt ?cf_eval ‹ntcf_Yoneda α β 
    by (rule AG.HomCod.cat_ntcf_Yoneda_is_ntcf)

  have Y': "Y' : N' CF.iso E' : op_cat 𝔄 ↦↦Cβ cat_Set β"
  proof(intro is_iso_ntcfI is_ntcfI')

    show "vfsequence Y'" unfolding Y'_def by simp
    show "vcard Y' = 5"
      unfolding Y'_def by (simp add: nat_omega_simps)
    show "vsv (Y'NTMap)" unfolding Y'_components by auto
    show "𝒟 (Y'NTMap) = op_cat 𝔄Obj"
      unfolding Y'_components by (simp add: cat_op_simps)
    show Y'_NTMap_a: "Y'NTMapa : N'ObjMapa isocat_Set β E'ObjMapa"
      if "a  op_cat 𝔄Obj" for a
      using that[unfolded cat_op_simps] assms(3)
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps
            cs_intro:
              cat_arrow_cs_intros
              cat_cs_intros
              cat_prod_cs_intros
              cat_FUNCT_cs_intros
        )
    then show "Y'NTMapa : N'ObjMapa cat_Set β E'ObjMapa"
      if "a  op_cat 𝔄Obj" for a
      by (intro cat_Set_is_arr_isomorphismD[OF Y'_NTMap_a[OF that]])
    show
      "Y'NTMapb Acat_Set β N'ArrMapf =
        E'ArrMapf Acat_Set β Y'NTMapa"
      if "f : a op_cat 𝔄 b" for a b f
    proof-
      note f = that[unfolded cat_op_simps]
      from f assms(3) show ?thesis
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps Y.ntcf_Comp_commute 
              cs_intro: cat_cs_intros cat_prod_cs_intros cat_FUNCT_cs_intros
          )+      
    qed
  qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

  have E'_def: "E' = HomO.Cβ𝔄(-,?𝔊c)"
  proof(rule cf_eqI)
    show "E' : op_cat 𝔄 ↦↦Cβ cat_Set β"
      by (cs_concl cs_intro: cat_cs_intros)
    from assms(3) show
      "HomO.Cβ𝔄(-,?𝔊c) : op_cat 𝔄 ↦↦Cβ cat_Set β"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    have dom_lhs: "𝒟 (E'ObjMap) = 𝔄Obj" unfolding E'_components by simp
    from assms(3) have dom_rhs: 
      "𝒟 (HomO.Cβ𝔄(-,?𝔊c)ObjMap) = 𝔄Obj"
      unfolding E'_components 
      by (cs_concl cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
    show "E'ObjMap = HomO.Cβ𝔄(-,?𝔊c)ObjMap"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume "a  𝔄Obj"
      with assms(3) show "E'ObjMapa = HomO.Cβ𝔄(-,?𝔊c)ObjMapa"
        by
          (
            cs_concl
              cs_simp: cat_op_simps cat_cs_simps
              cs_intro: cat_cs_intros cat_op_intros
          )
    qed (auto simp: E'_components cat_cs_intros assms(3))

    have dom_lhs: "𝒟 (E'ArrMap) = 𝔄Arr" unfolding E'_components by simp
    from assms(3) have dom_rhs: 
      "𝒟 (HomO.Cβ𝔄(-,?𝔊c)ArrMap) = 𝔄Arr"
      unfolding E'_components 
      by (cs_concl cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
    
    show "E'ArrMap = HomO.Cβ𝔄(-,?𝔊c)ArrMap"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)

      fix f assume prems: "f  𝔄Arr"
      then obtain a b where f: "f : a 𝔄 b" by auto
      have [cat_cs_simps]:
        "cf_eval_arrow  (ntcf_arrow (?H_A𝔊 f)) (CIdc) =
          cf_hom 𝔄 [f, 𝔄CId?𝔊c]"
        (is ?cf_eval_arrow = ?cf_hom_f𝔊c)
      proof-
        have cf_eval_arrow_f_CId_𝔊c:
          "?cf_eval_arrow :
            Hom 𝔄 b ?𝔊c cat_Set α Hom 𝔄 a ?𝔊c"
        proof(rule cf_eval_arrow_is_arr')
          from f show "?H_A𝔊 f :
            ?H_𝔄𝔊 b CF ?H_𝔄𝔊 a :  ↦↦Cα cat_Set α"
            by (cs_concl cs_intro: cat_cs_intros)
        qed
          (
            use f assms(3) in
              cs_concl
                  cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
          )+
        from f assms(3) have dom_lhs:
          "𝒟 (?cf_eval_arrowArrVal) = Hom 𝔄 b ?𝔊c"
          by
            (
              cs_concl
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
            )
        from assms(3) f Ran.HomCod.category_axioms have cf_hom_f𝔊c:
          "?cf_hom_f𝔊c :
            Hom 𝔄 b ?𝔊c cat_Set α Hom 𝔄 a ?𝔊c"
          by 
            (
              cs_concl cs_intro:
                cat_cs_intros cat_prod_cs_intros cat_op_intros
            )
        from f assms(3) have dom_rhs: 
          "𝒟 (?cf_hom_f𝔊cArrVal) = Hom 𝔄 b ?𝔊c"
          by
            (
              cs_concl 
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
            )

        show ?thesis
        proof(rule arr_Set_eqI)
          from cf_eval_arrow_f_CId_𝔊c show "arr_Set α ?cf_eval_arrow"
            by (auto dest: cat_Set_is_arrD(1))
          from cf_hom_f𝔊c show "arr_Set α ?cf_hom_f𝔊c"
            by (auto dest: cat_Set_is_arrD(1))
          show "?cf_eval_arrowArrVal = ?cf_hom_f𝔊cArrVal"
          proof(rule vsv_eqI, unfold dom_lhs dom_rhs, unfold in_Hom_iff)
            from f assms(3) show "vsv (?cf_eval_arrowArrVal)"
              by (cs_concl cs_intro: cat_cs_intros)
            from f assms(3) show "vsv (?cf_hom_f𝔊cArrVal)"
              by
                (
                  cs_concl
                    cs_simp: cat_cs_simps cat_op_simps 
                    cs_intro: cat_cs_intros cat_op_intros
                )            
            fix g assume "g : b 𝔄 ?𝔊c"
            with f assms(3) show 
              "?cf_eval_arrowArrValg = ?cf_hom_f𝔊cArrValg"
              by
                (
                  cs_concl
                    cs_simp: cat_cs_simps cat_op_simps
                    cs_intro: cat_cs_intros cat_op_intros
                )
          qed simp

        qed
          (
            use cf_eval_arrow_f_CId_𝔊c cf_hom_f𝔊c in 
              cs_concl cs_simp: cat_cs_simps
          )+

      qed
      
      from f prems assms(3) show
        "E'ArrMapf = HomO.Cβ𝔄(-,?𝔊c)ArrMapf"
        by
          (
            cs_concl
              cs_simp: cat_op_simps cat_cs_simps 
              cs_intro: cat_cs_intros cat_op_intros
          )

    qed (auto simp: E'_components cat_cs_intros assms(3))

  qed simp_all

  from Y' have inv_Y': "inv_ntcf Y' :
    HomO.Cβ𝔄(-,?𝔊c) CF.iso N' : op_cat 𝔄 ↦↦Cβ cat_Set β"
    unfolding E'_def by (auto intro: iso_ntcf_is_arr_isomorphism)

  interpret N'': is_functor β ‹op_cat 𝔄 ‹cat_Set β ‹L_10_5_N α β 𝔗 𝔎 c
    by (rule L_10_5_N_is_functor[OF β αβ assms])


  (** ψ **)

  define ψ :: V
    where "ψ =
      [
        (λa𝔄Obj. ?ntcf_ua_fo aNTMapcf_map (?H_ℭ c)),
        N',
        L_10_5_N α β 𝔗 𝔎 c,
        op_cat 𝔄,
        cat_Set β
      ]"

  have ψ_components:
    "ψNTMap = (λa𝔄Obj. ?ntcf_ua_fo aNTMapcf_map (?H_ℭ c))"
    "ψNTDom = N'"
    "ψNTCod = L_10_5_N α β 𝔗 𝔎 c"
    "ψNTDGDom = op_cat 𝔄"
    "ψNTDGCod = cat_Set β"
    unfolding ψ_def nt_field_simps by (simp_all add: nat_omega_simps)

  note [cat_cs_simps] = Y'_components(2-5)

  have ψ_NTMap_app[cat_cs_simps]: 
    "ψNTMapa = ?ntcf_ua_fo aNTMapcf_map (?H_ℭ c)" 
    if "a  𝔄Obj" for a
    using that unfolding ψ_components by simp

  have ψ: "ψ : N' CF.iso L_10_5_N α β 𝔗 𝔎 c : op_cat 𝔄 ↦↦Cβ cat_Set β"
  proof-

    show ?thesis
    proof(intro is_iso_ntcfI is_ntcfI')

      show "vfsequence ψ" unfolding ψ_def by auto
      show "vcard ψ = 5" unfolding ψ_def by (simp_all add: nat_omega_simps)
      show "N' : op_cat 𝔄 ↦↦Cβ cat_Set β" by (rule N')
      show "L_10_5_N α β 𝔗 𝔎 c : op_cat 𝔄 ↦↦Cβ cat_Set β"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show "ψNTDom = N'" unfolding ψ_components by simp
      show "ψNTCod = L_10_5_N α β 𝔗 𝔎 c" unfolding ψ_components by simp
      show "ψNTDGDom = op_cat 𝔄" unfolding ψ_components by simp
      show "ψNTDGCod = cat_Set β" unfolding ψ_components by simp
      show "vsv (ψNTMap)" unfolding ψ_components by simp
      show "𝒟 (ψNTMap) = op_cat 𝔄Obj" 
        unfolding ψ_components by (simp add: cat_op_simps)

      show ψ_NTMap_is_arr_isomorphism[unfolded cat_op_simps]:
        "ψNTMapa : N'ObjMapa isocat_Set β L_10_5_N α β 𝔗 𝔎 cObjMapa"
        if "a  op_cat 𝔄Obj" for a
      proof-
        note a = that[unfolded cat_op_simps]
        interpret ε: 
          is_cat_rKe_preserves α 𝔅  𝔄 ‹cat_Set α 𝔎 𝔗 𝔊 ?H_𝔄 a ε
          by (rule cat_pw_rKe_preserved[OF a])
        interpret: 
          is_cat_rKe α 𝔅  ‹cat_Set α 𝔎 ?H_𝔄𝔗 a ?H_𝔄𝔊 a ?H_𝔄ε a
          by (rule ε.cat_rKe_preserves)
        interpret is_iso_ntcf
          β
          ‹op_cat (?FUNCT )
          ‹cat_Set β
          ?H_FUNCT  (?H_𝔄𝔊 a)
          ?H_FUNCT 𝔅 (?H_𝔄𝔗 a) CF op_cf ?SET_𝔎
          ?ntcf_ua_fo a
          by (rule aε.cat_rKe_ntcf_ua_fo_is_iso_ntcf_if_ge_Limit[OF β αβ])
        have "cf_map (?H_ℭ c)  ?FUNCT Obj"
          by
            (
              cs_concl 
                cs_simp: cat_cs_simps cat_FUNCT_cs_simps 
                cs_intro: cat_cs_intros cat_FUNCT_cs_intros
            )
        from 
          iso_ntcf_is_arr_isomorphism[unfolded cat_op_simps, OF this] 
          a assms αβ 
        show ?thesis
          by (*very slow*)
            (
              cs_prems 
                cs_simp: 
                  cat_cs_simps cat_Kan_cs_simps cat_FUNCT_cs_simps cat_op_simps 
                cs_intro: 
                  cat_small_cs_intros 
                  cat_Kan_cs_intros
                  cat_cs_intros
                  cat_FUNCT_cs_intros
                  cat_op_intros
            )
      qed
      show ψ_NTMap_is_arr[unfolded cat_op_simps]: 
        "ψNTMapa : N'ObjMapa cat_Set β L_10_5_N α β 𝔗 𝔎 cObjMapa"
        if "a  op_cat 𝔄Obj" for a
        by 
          (
            rule cat_Set_is_arr_isomorphismD[
              OF ψ_NTMap_is_arr_isomorphism[OF that[unfolded cat_op_simps]]
              ]
          )

      show 
        "ψNTMapb Acat_Set β N'ArrMapf =
          L_10_5_N α β 𝔗 𝔎 cArrMapf Acat_Set β ψNTMapa"
        if "f : a op_cat 𝔄 b" for a b f
      proof-

        note f = that[unfolded cat_op_simps]
        from f have a: "a  𝔄Obj" and b: "b  𝔄Obj" by auto

        interpret p_a_ε: 
          is_cat_rKe_preserves α 𝔅  𝔄 ‹cat_Set α 𝔎 𝔗 𝔊 ?H_𝔄 a ε
          by (rule cat_pw_rKe_preserved[OF a])
        interpret a_ε: is_cat_rKe 
          α 𝔅  ‹cat_Set α 𝔎 ?H_𝔄𝔗 a ?H_𝔄𝔊 a ?H_𝔄ε a
          by (rule p_a_ε.cat_rKe_preserves)
        interpret ntcf_ua_fo_a_ε: is_iso_ntcf
          β ?ua_NTDGDom ‹cat_Set β ?ua_NTDom a ?ua_NTCod a ?ua a
          by (rule a_ε.cat_rKe_ntcf_ua_fo_is_iso_ntcf_if_ge_Limit[OF β αβ])

        interpret p_b_ε:
          is_cat_rKe_preserves α 𝔅  𝔄 ‹cat_Set α 𝔎 𝔗 𝔊 ?H_𝔄 b ε
          by (rule cat_pw_rKe_preserved[OF b])
        interpret b_ε: is_cat_rKe 
          α 𝔅  ‹cat_Set α 𝔎 ?H_𝔄𝔗 b ?H_𝔄𝔊 b ?H_𝔄ε b
          by (rule p_b_ε.cat_rKe_preserves)
        interpret ntcf_ua_fo_b_ε: is_iso_ntcf
          β ?ua_NTDGDom ‹cat_Set β ?ua_NTDom b ?ua_NTCod b ?ua b
          by (rule b_ε.cat_rKe_ntcf_ua_fo_is_iso_ntcf_if_ge_Limit[OF β αβ])

        interpret 𝔎_SET: is_tiny_functor β ?FUNCT  ?FUNCT 𝔅 ?SET_𝔎
          by 
            (
              rule exp_cat_cf_is_tiny_functor[
                OF β αβ AG.category_cat_Set AG.is_functor_axioms
                ]
            )
        from f interpret Hom_f:
          is_ntcf α 𝔄 ‹cat_Set α ?H_𝔄 a ?H_𝔄 b ?H_A f
          by (cs_concl cs_intro: cat_cs_intros)

        let ?cf_hom_lhs =
          ‹
            cf_hom
              (?FUNCT )
              [ntcf_arrow (ntcf_id (?H_ℭ c)), ntcf_arrow (?H_A𝔊 f)]
        let ?cf_hom_rhs = 
          ‹
            cf_hom
              (?FUNCT 𝔅)
              [
                ntcf_arrow (ntcf_id (?H_ℭ c CF 𝔎)),
                ntcf_arrow (?H_A f NTCF-CF 𝔗)
              ]
        let ?dom =
          ‹Hom (?FUNCT ) (cf_map (?H_ℭ c)) (cf_map (?H_𝔄𝔊 a))
        let ?cod = ‹Hom (?FUNCT 𝔅) (cf_map (?H_ℭ𝔎 c)) (cf_map (?H_𝔄𝔗 b))
        let ?cf_hom_lhs_umap_fo_inter =
          ‹Hom (?FUNCT ) (cf_map (?H_ℭ c)) (cf_map (?H_𝔄𝔊 b))
        let ?umap_fo_cf_hom_rhs_inter =
          ‹Hom (?FUNCT 𝔅) (cf_map (?H_ℭ𝔎 c)) (cf_map (?H_𝔄𝔗 a))

        have [cat_cs_simps]:
          "?umap_fo b Acat_Set β ?cf_hom_lhs =
            ?cf_hom_rhs Acat_Set β ?umap_fo a"
        proof-

          from f assms(3) αβ have cf_hom_lhs:
            "?cf_hom_lhs : ?dom cat_Set β ?cf_hom_lhs_umap_fo_inter"
            by
              (
                cs_concl
                  cs_simp: cat_cs_simps cat_FUNCT_cs_simps
                  cs_intro:
                    cat_cs_intros
                    cat_FUNCT_cs_intros
                    cat_prod_cs_intros
                    cat_op_intros
              )
          from f assms(3) αβ have umap_fo_b:
            "?umap_fo b : ?cf_hom_lhs_umap_fo_inter cat_Set β ?cod"
            by
              (
                cs_concl
                  cs_simp: cat_cs_simps cat_FUNCT_cs_simps
                  cs_intro: 
                    cat_small_cs_intros
                    cat_cs_intros
                    cat_FUNCT_cs_intros
                    cat_prod_cs_intros
                    cat_op_intros
              )
          from cf_hom_lhs umap_fo_b have umap_fo_cf_hom_lhs:
            "?umap_fo b Acat_Set β ?cf_hom_lhs : ?dom cat_Set β ?cod"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          then have dom_umap_fo_cf_hom_lhs: 
            "𝒟 ((?umap_fo b Acat_Set β ?cf_hom_lhs)ArrVal) = ?dom"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

          from f assms(3) αβ have cf_hom_rhs: 
            "?cf_hom_rhs : ?umap_fo_cf_hom_rhs_inter cat_Set β ?cod"
            by (*slow*)
              (
                cs_concl
                  cs_simp: cat_cs_simps cat_FUNCT_cs_simps
                  cs_intro:
                    cat_cs_intros
                    cat_FUNCT_cs_intros
                    cat_prod_cs_intros
                    cat_op_intros
              )
          from f assms(3) αβ have umap_fo_a:
            "?umap_fo a : ?dom cat_Set β ?umap_fo_cf_hom_rhs_inter"
            by (*slow*)
              (
                cs_concl
                  cs_simp: cat_cs_simps cat_FUNCT_cs_simps
                  cs_intro:
                    cat_small_cs_intros 
                    cat_cs_intros 
                    cat_FUNCT_cs_intros 
                    cat_prod_cs_intros 
                    cat_op_intros
              )
          from cf_hom_rhs umap_fo_a have cf_hom_rhs_umap_fo_a: 
            "?cf_hom_rhs Acat_Set β ?umap_fo a : ?dom cat_Set β ?cod"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros )
          then have dom_cf_hom_rhs_umap_fo_a: 
            "𝒟 ((?cf_hom_rhs Acat_Set β ?umap_fo a)ArrVal) = ?dom"
            by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          
          show ?thesis
          proof(rule arr_Set_eqI)

            from umap_fo_cf_hom_lhs show arr_Set_umap_fo_cf_hom_lhs: 
              "arr_Set β (?umap_fo b Acat_Set β ?cf_hom_lhs)"
              by (auto dest: cat_Set_is_arrD(1))
            from cf_hom_rhs_umap_fo_a show arr_Set_cf_hom_rhs_umap_fo_a: 
              "arr_Set β (?cf_hom_rhs Acat_Set β ?umap_fo a)"
              by (auto dest: cat_Set_is_arrD(1))

            show 
              "(?umap_fo b Acat_Set β ?cf_hom_lhs)ArrVal =
                (?cf_hom_rhs Acat_Set β ?umap_fo a)ArrVal"
            proof
              (
                rule vsv_eqI, 
                unfold 
                  dom_umap_fo_cf_hom_lhs dom_cf_hom_rhs_umap_fo_a in_Hom_iff; 
                (rule refl)?
              )

              fix  assume prems:
                " : cf_map (?H_ℭ c) ?FUNCT  cf_map (?H_𝔄𝔊 a)"

              let ?ℌ = ‹ntcf_of_ntcf_arrow  (cat_Set α) 
              let ?lhs = ?H_𝔄ε b NTCF ((?H_A𝔊 f NTCF ?ℌ) NTCF-CF 𝔎)
              let ?rhs = 
                (?H_A f NTCF-CF 𝔗 NTCF ?H_𝔄ε a NTCF (?ℌ NTCF-CF 𝔎))
              let ?cf_hom_𝔄ε = λb b'. cf_hom 𝔄 [𝔄CIdb, εNTMapb']
              let ?Yc = λQ. Yoneda_component (?H_𝔄 b) a f Q
              let ?ℌ𝔎 = λb'. ?ℌNTMap𝔎ObjMapb'
              let ?𝔊𝔎 = λb'. 𝔊ObjMap𝔎ObjMapb'

              have [cat_cs_simps]: 
                "cf_of_cf_map  (cat_Set α) (cf_map (?H_ℭ c)) = ?H_ℭ c"
                by (cs_concl cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
              have [cat_cs_simps]: 
                "cf_of_cf_map  (cat_Set α) (cf_map (?H_𝔄𝔊 a)) = ?H_𝔄𝔊 a"
                by (cs_concl cs_simp: cat_FUNCT_cs_simps cs_intro: cat_cs_intros)
              note= cat_FUNCT_is_arrD[OF prems, unfolded cat_cs_simps]
              have Hom_c: "?H_ℭ𝔎 c : 𝔅 ↦↦Cα cat_Set α"
                by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

              have [cat_cs_simps]: "?lhs = ?rhs"
              proof(rule ntcf_eqI)
                from(1) f show lhs: 
                  "?lhs : ?H_ℭ𝔎 c CF ?H_𝔄𝔗 b : 𝔅 ↦↦Cα cat_Set α"
                  by (cs_concl cs_simp: cs_intro: cat_cs_intros)
                then have dom_lhs: "𝒟 (?lhsNTMap) = 𝔅Obj" 
                  by (cs_concl cs_simp: cat_cs_simps)+
                from(1) f show rhs: 
                  "?rhs : ?H_ℭ𝔎 c CF ?H_𝔄𝔗 b : 𝔅 ↦↦Cα cat_Set α"
                  by (cs_concl cs_simp: cs_intro: cat_cs_intros)
                then have dom_rhs: "𝒟 (?rhsNTMap) = 𝔅Obj"
                  by (cs_concl cs_simp: cat_cs_simps)+
                have [cat_cs_simps]:
                  "?cf_hom_𝔄ε b b' Acat_Set α 
                    (?Yc (?𝔊𝔎 b') Acat_Set α ?ℌ𝔎 b') =
                      ?Yc (𝔗ObjMapb') Acat_Set α
                        (?cf_hom_𝔄ε a b' Acat_Set α ?ℌ𝔎 b')"
                  (is ?lhs_Set = ?rhs_Set)
                  if "b'  𝔅Obj" for b'
                proof-
                  let ?𝔎b' = 𝔎ObjMapb'
                  from(1) f that assms(3) Ran.HomCod.category_axioms 
                  have lhs_Set_is_arr: "?lhs_Set :
                    Hom  c (?𝔎b') cat_Set α Hom 𝔄 b (𝔗ObjMapb')"
                    by
                      (
                        cs_concl
                          cs_simp: cat_cs_simps cat_op_simps 
                          cs_intro: 
                            cat_cs_intros cat_prod_cs_intros cat_op_intros
                      )
                  then have dom_lhs_Set: "𝒟 (?lhs_SetArrVal) = Hom  c ?𝔎b'" 
                    by (cs_concl cs_simp: cat_cs_simps)
                  from(1) f that assms(3) Ran.HomCod.category_axioms 
                  have rhs_Set_is_arr: "?rhs_Set :
                    Hom  c (?𝔎b') cat_Set α Hom 𝔄 b (𝔗ObjMapb')"
                    by
                      (
                        cs_concl
                          cs_simp: cat_cs_simps cat_op_simps 
                          cs_intro:
                            cat_cs_intros cat_prod_cs_intros cat_op_intros
                      )
                  then have dom_rhs_Set: "𝒟 (?rhs_SetArrVal) = Hom  c ?𝔎b'" 
                    by (cs_concl cs_simp: cat_cs_simps)
                show ?thesis
                proof(rule arr_Set_eqI)
                  from lhs_Set_is_arr show arr_Set_lhs_Set: "arr_Set α ?lhs_Set" 
                    by (auto dest: cat_Set_is_arrD(1))
                  from rhs_Set_is_arr show arr_Set_rhs_Set: "arr_Set α ?rhs_Set"
                    by (auto dest: cat_Set_is_arrD(1))
                  show "?lhs_SetArrVal = ?rhs_SetArrVal"
                  proof(rule vsv_eqI, unfold dom_lhs_Set dom_rhs_Set in_Hom_iff)
                    fix h assume "h : c  ?𝔎b'"
                    with(1) f that assms Ran.HomCod.category_axioms show 
                      "?lhs_SetArrValh = ?rhs_SetArrValh"
                      by (*exceptionally slow*) 
                        (
                          cs_concl 
                            cs_simp: cat_cs_simps cat_op_simps 
                            cs_intro: 
                              cat_cs_intros cat_prod_cs_intros cat_op_intros
                        )
                  qed (use arr_Set_lhs_Set arr_Set_rhs_Set in auto)
                qed
                  (
                    use lhs_Set_is_arr rhs_Set_is_arr in
                      cs_concl cs_simp: cat_cs_simps
                  )+

              qed

              show "?lhsNTMap = ?rhsNTMap"
              proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
                fix b' assume "b'  𝔅Obj"
                with(1) f assms(3) show "?lhsNTMapb' = ?rhsNTMapb'"
                  by (*slow*)
                    (
                      cs_concl
                        cs_simp: cat_cs_simps cat_op_simps 
                        cs_intro: cat_cs_intros
                    )
              qed (cs_concl cs_intro: cat_cs_intros)

            qed simp_all

            from 
              assms(3) f ℌ(1) prems αβ 
              (*speedup*)
              Ran.HomCod.category_axioms 
              FUNCT_ℭ.category_axioms
              FUNCT_𝔅.category_axioms
              AG.is_functor_axioms
              Ran.is_functor_axioms
              Hom_f.is_ntcf_axioms
            show
              "(?umap_fo b Acat_Set β ?cf_hom_lhs)ArrVal =
                (?cf_hom_rhs Acat_Set β ?umap_fo a)ArrVal"
                by (subst (1 2)(2)) (*exceptionally slow*)
                (
                  cs_concl
                    cs_simp: cat_cs_simps cat_FUNCT_cs_simps cat_op_simps
                    cs_intro:
                      cat_cs_intros 
                      cat_prod_cs_intros 
                      cat_FUNCT_cs_intros
                      cat_op_intros
                )

            qed
              (
                use arr_Set_umap_fo_cf_hom_lhs arr_Set_cf_hom_rhs_umap_fo_a in
                  auto
              )

          qed
            (
              use umap_fo_cf_hom_lhs cf_hom_rhs_umap_fo_a in
                cs_concl cs_simp: cat_cs_simps
            )+

        qed

        from f assms αβ show ?thesis
          by (*slow*)
            (
              cs_concl
                cs_simp: cat_cs_simps cat_Kan_cs_simps cat_FUNCT_cs_simps
                cs_intro: cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
            )

      qed

    qed auto

  qed


  (**main**)

  from L_10_5_χ_is_iso_ntcf[OF β αβ assms] have inv_χ:
    "inv_ntcf (L_10_5_χ α β 𝔗 𝔎 c) :
      L_10_5_N α β 𝔗 𝔎 c CF.iso cf_Cone α β ?𝔗_c𝔎 :
      op_cat 𝔄 ↦↦Cβ cat_Set β"
    by (auto intro: iso_ntcf_is_arr_isomorphism)
 
  define φ where "φ = inv_ntcf (L_10_5_χ α β 𝔗 𝔎 c) NTCF ψ NTCF inv_ntcf Y'"
  
  from inv_Y' ψ inv_χ have φ: "φ :
    HomO.Cβ𝔄(-,?𝔊c) CF.iso cf_Cone α β ?𝔗_c𝔎 :
    op_cat 𝔄 ↦↦Cβ cat_Set β"
    unfolding φ_def by (cs_concl cs_intro: cat_cs_intros)

  interpret φ: is_iso_ntcf
    β ‹op_cat 𝔄 ‹cat_Set β HomO.Cβ𝔄(-,?𝔊c) ‹cf_Cone α β ?𝔗_c𝔎 φ
    by (rule φ)

  let ?φ_𝔊c_CId = φNTMap?𝔊cArrVal𝔄CId?𝔊c
  let ?ntcf_φ_𝔊c_CId = ‹ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 ?φ_𝔊c_CId

  from AG.vempty_is_zet assms(3) have Δ: " : 𝔄 ↦↦Cα ?c𝔎_𝔄"
    by
      (
        cs_concl
          cs_simp: cat_comma_cs_simps 
          cs_intro: cat_small_cs_intros cat_cs_intros cat_comma_cs_intros
      )
  from assms(3) have 𝔊c: "?𝔊c  𝔄Obj" 
    by (cs_concl cs_intro: cat_cs_intros)
  from AG.vempty_is_zet have 𝔗_c𝔎: "cf_map (?𝔗_c𝔎)  ?c𝔎_𝔄Obj"
    by
      (
        cs_concl
          cs_simp: cat_Funct_components(1) 
          cs_intro: cat_small_cs_intros cat_FUNCT_cs_intros
      )

  from
    φ.ntcf_NTMap_is_arr[unfolded cat_op_simps, OF 𝔊c]
    assms(3)
    AG.vempty_is_zet
    β.vempty_is_zet
    αβ
  have φ_𝔊c: "φNTMap?𝔊c :
    Hom 𝔄 ?𝔊c?𝔊c cat_Set β 
    Hom ?c𝔎_𝔄 (cf_map (?cf_c𝔎_𝔄 ?𝔊c)) (cf_map ?𝔗_c𝔎)"
    by (*very slow*)
      (
        cs_prems
          cs_simp:
            cat_cs_simps
            cat_Kan_cs_simps
            cat_comma_cs_simps 
            cat_op_simps 
            cat_Funct_components(1) 
          cs_intro: 
            cat_small_cs_intros
            cat_Kan_cs_intros
            cat_comma_cs_intros 
            cat_cs_intros 
            cat_FUNCT_cs_intros 
            cat_op_intros 
            category.cat_category_if_ge_Limit[where α=α and β=β]
            is_functor.cf_is_functor_if_ge_Limit[where α=α and β=β]
      )

  with assms(3) have φ_𝔊c_CId: 
    "?φ_𝔊c_CId : cf_map (?cf_c𝔎_𝔄 ?𝔊c) ?c𝔎_𝔄 cf_map ?𝔗_c𝔎"
    by (cs_concl cs_intro: cat_cs_intros)
  have ntcf_arrow_φ_𝔊c_CId: "ntcf_arrow ?ntcf_φ_𝔊c_CId = ?φ_𝔊c_CId"
    by (rule cat_Funct_is_arrD(2)[OF φ_𝔊c_CId, symmetric])
  have ua: "universal_arrow_fo  (cf_map (?𝔗_c𝔎)) ?𝔊c ?φ_𝔊c_CId"
    by 
      (
        rule is_functor.cf_universal_arrow_fo_if_is_iso_ntcf_if_ge_Limit[
          OF Δ β αβ 𝔊c 𝔗_c𝔎 φ[unfolded cf_Cone_def cat_cs_simps]
          ]
      )
  moreover have ntcf_φ_𝔊c_CId: 
    "?ntcf_φ_𝔊c_CId : ?𝔊c <CF.cone ?𝔗_c𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
  proof(intro is_cat_coneI)
    from cat_Funct_is_arrD(1)[OF φ_𝔊c_CId] assms(3) AG.vempty_is_zet show 
      "ntcf_of_ntcf_arrow (c CF 𝔎) 𝔄 ?φ_𝔊c_CId :
        ?cf_c𝔎_𝔄 ?𝔊c CF.tm ?𝔗_c𝔎 : c CF 𝔎 ↦↦C.tmα 𝔄"
      by
        (
          cs_prems
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros
        )
  qed (rule 𝔊c)
  ultimately have "?ntcf_φ_𝔊c_CId : ?𝔊c <CF.lim ?𝔗_c𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    by 
      (
        intro is_cat_limitI[
          where u=?ntcf_φ_𝔊c_CId, unfolded ntcf_arrow_φ_𝔊c_CId
          ]
      )
  then show ?thesis using that by auto

qed



subsection‹The limit for the pointwise Kan extension›


subsubsection‹Definition and elementary properties›


text‹See Theorem 3 in Chapter X-5 in \cite{mac_lane_categories_2010}.›

definition the_pw_cat_rKe_limit :: "V  V  V  V  V  V"
  where "the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊 c =
    [
      𝔊ObjMapc,
      (
        SOME UA.
          UA : 𝔊ObjMapc <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔗HomCod
      )
    ]"


text‹Components.›

lemma the_pw_cat_rKe_limit_components:
  shows "the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊 cUObj = 𝔊ObjMapc"
    and "the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊 cUArr = 
      (
        SOME UA.
          UA : 𝔊ObjMapc <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔗HomCod
      )"
  unfolding the_pw_cat_rKe_limit_def ua_field_simps
  by (simp_all add: nat_omega_simps)

context is_functor
begin

lemmas the_pw_cat_rKe_limit_components' = 
  the_pw_cat_rKe_limit_components[where 𝔗=𝔉, unfolded cat_cs_simps]

end


subsubsection‹The limit for the pointwise Kan extension is a limit›

lemma (in is_cat_pw_rKe) cat_pw_rKe_the_pw_cat_rKe_limit_is_limit:
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
    and "c  Obj"
  shows "the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊 cUArr :
    the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊 cUObj <CF.lim 𝔗 CF c OCF 𝔎 :
    c CF 𝔎 ↦↦Cα 𝔄"
proof-
  from cat_pw_rKe_ex_cat_limit[OF assms] obtain UA 
    where UA: "UA : 𝔊ObjMapc <CF.lim 𝔗 CF c OCF 𝔎 : c CF 𝔎 ↦↦Cα 𝔄"
    by auto
  show ?thesis
    unfolding the_pw_cat_rKe_limit_components
    by (rule someI2, unfold cat_cs_simps, rule UA)
qed

lemma (in is_cat_pw_rKe) cat_pw_rKe_the_ntcf_rKe_is_cat_rKe: 
  assumes "𝔎 : 𝔅 ↦↦C.tmα "
    and "𝔗 : 𝔅 ↦↦C.tmα 𝔄"
  shows "the_ntcf_rKe α 𝔗 𝔎 (the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊) :
    the_cf_rKe α 𝔗 𝔎 (the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊) CF 𝔎 CF.rKeα 𝔗 :
    𝔅 C  C 𝔄"
proof-
  interpret 𝔗: is_tm_functor α 𝔅 𝔄 𝔗 by (rule assms(2))
  show "the_ntcf_rKe α 𝔗 𝔎 (the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊) :
    the_cf_rKe α 𝔗 𝔎 (the_pw_cat_rKe_limit α 𝔎 𝔗 𝔊) CF 𝔎 CF.rKeα 𝔗 :
    𝔅 C  C 𝔄"
    by
      (
        rule
          the_ntcf_rKe_is_cat_rKe
            [
              OF
                assms(1)
                ntcf_rKe.NTCod.is_functor_axioms 
                cat_pw_rKe_the_pw_cat_rKe_limit_is_limit[OF assms]
            ]
      )
qed

text‹\newpage›

end

Theory CZH_UCAT_PWKan_Example

(* Copyright 2021 (C) Mihails Milehins *)

section‹Pointwise Kan extensions: application example›
theory CZH_UCAT_PWKan_Example
  imports
    CZH_Elementary_Categories.CZH_ECAT_Ordinal
    CZH_UCAT_PWKan
begin



subsection‹Background›


text‹
The application example presented in this section is based on 
Exercise 6.1.ii in \cite{riehl_category_2016}.
›

(*TODO: is the explicit elimination rule necessary?*)
lemma cat_ordinal_2_is_arrE:
  assumes "f : a cat_ordinal (2) b"
  obtains "f = [0, 0]" and " a = 0" and "b = 0" 
    | "f = [0, 1]" and "a = 0" and "b = 1"
    | "f = [1, 1]" and "a = 1" and "b = 1"
  using cat_ordinal_is_arrD[OF assms] unfolding two by auto

(*TODO: is the explicit elimination rule necessary?*)
lemma cat_ordinal_3_is_arrE:
  assumes "f : a cat_ordinal (3) b"
  obtains "f = [0, 0]" and " a = 0" and "b = 0" 
    | "f = [0, 1]" and "a = 0" and "b = 1"
    | "f = [0, 2]" and "a = 0" and "b = 2"
    | "f = [1, 1]" and "a = 1" and "b = 1"
    | "f = [1, 2]" and "a = 1" and "b = 2"
    | "f = [2, 2]" and "a = 2" and "b = 2"
  using cat_ordinal_is_arrD[OF assms] unfolding three by auto

lemma 0123: "0  2" "1  2" "0  3" "1  3" "2  3" by auto



subsection𝔎23›


subsubsection‹Definition and elementary properties›

definition 𝔎23 :: V
  where "𝔎23 =
    [
      (λacat_ordinal (2)Obj. if a = 0 then 0 else 2), 
      (
        λfcat_ordinal (2)Arr.
         if f = [0, 0]  [0, 0]
          | f = [0, 1]  [0, 2]
          | f = [1, 1]  [2, 2]
          | otherwise  0
      ), 
      cat_ordinal (2),
      cat_ordinal (3)
    ]"


text‹Components.›

lemma 𝔎23_components:
  shows "𝔎23ObjMap = (λacat_ordinal (2)Obj. if a = 0 then 0 else 2)"
    and "𝔎23ArrMap =
      (
        λfcat_ordinal (2)Arr.
         if f = [0, 0]  [0, 0]
          | f = [0, 1]  [0, 2]
          | f = [1, 1]  [2, 2]
          | otherwise  0
      )"
    and [cat_Kan_cs_simps]: "𝔎23HomDom = cat_ordinal (2)"
    and [cat_Kan_cs_simps]: "𝔎23HomCod = cat_ordinal (3)"
  unfolding 𝔎23_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda 𝔎23_components(1)
  |vsv 𝔎23_ObjMap_vsv[cat_Kan_cs_intros]|
  |vdomain 𝔎23_ObjMap_vdomain[cat_Kan_cs_simps]|
  |app 𝔎23_ObjMap_app|

lemma 𝔎23_ObjMap_app_0[cat_Kan_cs_simps]: 
  assumes "x = 0"
  shows "𝔎23ObjMapx = 0"
  by 
    (
      cs_concl 
        cs_simp: 𝔎23_ObjMap_app cat_ordinal_cs_simps V_cs_simps assms 
        cs_intro: nat_omega_intros
    )

lemma 𝔎23_ObjMap_app_1[cat_Kan_cs_simps]: 
  assumes "x = 1"
  shows "𝔎23ObjMapx = 2"
  by 
    (
      cs_concl 
        cs_simp: 
          cat_ordinal_cs_simps V_cs_simps omega_of_set 𝔎23_ObjMap_app assms
        cs_intro: nat_omega_intros V_cs_intros
    )


subsubsection‹Arrow map›

mk_VLambda 𝔎23_components(2)
  |vsv 𝔎23_ArrMap_vsv[cat_Kan_cs_intros]|
  |vdomain 𝔎23_ArrMap_vdomain[cat_Kan_cs_simps]|
  |app 𝔎23_ArrMap_app|

lemma 𝔎23_ArrMap_app_00[cat_Kan_cs_simps]: 
  assumes "f = [0, 0]"
  shows "𝔎23ArrMapf = [0, 0]"
  unfolding assms
  by 
    (
      cs_concl 
        cs_simp: 𝔎23_ArrMap_app cat_ordinal_cs_simps V_cs_simps 
        cs_intro: cat_ordinal_cs_intros nat_omega_intros
    )

lemma 𝔎23_ArrMap_app_01[cat_Kan_cs_simps]: 
  assumes "f = [0, 1]"
  shows "𝔎23ArrMapf = [0, 2]"
proof-
  have "[0, 1]  ordinal_arrs (2)"
    by 
      (
        cs_concl 
          cs_simp: omega_of_set 
          cs_intro: cat_ordinal_cs_intros V_cs_intros nat_omega_intros
      )
  then show ?thesis
    unfolding assms by (simp add: 𝔎23_components cat_ordinal_components)
qed

lemma 𝔎23_ArrMap_app_11[cat_Kan_cs_simps]: 
  assumes "f = [1, 1]"
  shows "𝔎23ArrMapf = [2, 2]"
proof-
  have "[1, 1]  ordinal_arrs (2)"
    by 
      (
        cs_concl 
          cs_simp: omega_of_set 
          cs_intro: cat_ordinal_cs_intros V_cs_intros nat_omega_intros
      )
  then show ?thesis
    unfolding assms by (simp add: 𝔎23_components cat_ordinal_components)
qed


subsubsection𝔎23› is a tiny functor›

lemma (in 𝒵) 𝔎23_is_functor: "𝔎23 : cat_ordinal (2) ↦↦Cα cat_ordinal (3)"
proof-

  from ord_of_nat_ω interpret cat_ordinal_2: finite_category α ‹cat_ordinal (2)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)
  from ord_of_nat_ω interpret cat_ordinal_3: finite_category α ‹cat_ordinal (3)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)

  show ?thesis
  proof(intro is_tiny_functorI' is_functorI')

    show "vfsequence 𝔎23" unfolding 𝔎23_def by auto
    show "vcard 𝔎23 = 4" unfolding 𝔎23_def by (simp add: nat_omega_simps)

    show " (𝔎23ObjMap)  cat_ordinal (3)Obj"
    proof
      (
        rule vsv.vsv_vrange_vsubset, 
        unfold cat_Kan_cs_simps cat_ordinal_cs_simps, 
        intro cat_Kan_cs_intros
      )
      fix x assume "x  2"
      then consider x = 0 | x = 1 unfolding two by auto
      then show "𝔎23ObjMapx  3"
        by (cases, use nothing in simp_all only:)
          (
            cs_concl 
              cs_simp: cat_Kan_cs_simps omega_of_set cs_intro: nat_omega_intros
          )+
    qed

    show "𝔎23ArrMapf : 𝔎23ObjMapa cat_ordinal (3) 𝔎23ObjMapb"
      if "f : a cat_ordinal (2) b" for a b f
      using that 
      by (elim cat_ordinal_2_is_arrE; simp only:) 
        (
          cs_concl
            cs_simp: omega_of_set cat_Kan_cs_simps
            cs_intro: nat_omega_intros V_cs_intros cat_ordinal_cs_intros
        )

    show 
      "𝔎23ArrMapg Acat_ordinal (2) f =
        𝔎23ArrMapg Acat_ordinal (3) 𝔎23ArrMapf"
      if "g : b cat_ordinal (2) c" and "f : a cat_ordinal (2) b"
      for b c g a f 
    proof-
      have "0  3" "1  3" "2  3" by auto
      then show ?thesis
        using that
        by (elim cat_ordinal_2_is_arrE; simp only:)
          (
            cs_concl 
              cs_simp: cat_ordinal_cs_simps cat_Kan_cs_simps  
              cs_intro: V_cs_intros cat_ordinal_cs_intros
          )+    
    qed

    show 
      "𝔎23ArrMapcat_ordinal (2)CIdc =
        cat_ordinal (3)CId𝔎23ObjMapc"
      if "c  cat_ordinal (2)Obj" for c
    proof-
      from that consider c = 0 | c = 1
        unfolding cat_ordinal_components(1) two by auto
      then show ?thesis
        by (cases, use nothing in simp_all only:) 
          (
            cs_concl
              cs_simp: omega_of_set cat_Kan_cs_simps cat_ordinal_cs_simps  
              cs_intro: nat_omega_intros cat_ordinal_cs_intros
          )
    qed

  qed (auto intro!: cat_cs_intros simp: 𝔎23_components)

qed

lemma (in 𝒵) 𝔎23_is_functor'[cat_Kan_cs_intros]:
  assumes "𝔄' = cat_ordinal (2)"
    and "𝔅' = cat_ordinal (3)"
  shows "𝔎23 : 𝔄' ↦↦Cα 𝔅'"
  unfolding assms by (rule 𝔎23_is_functor)

lemmas [cat_Kan_cs_intros] = 𝒵.𝔎23_is_functor'

lemma (in 𝒵) 𝔎23_is_tiny_functor: 
  "𝔎23 : cat_ordinal (2) ↦↦C.tinyα cat_ordinal (3)"
proof-
  from ord_of_nat_ω interpret cat_ordinal_2: finite_category α ‹cat_ordinal (2)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)
  from ord_of_nat_ω interpret cat_ordinal_3: finite_category α ‹cat_ordinal (3)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)
  show ?thesis
    by (intro is_tiny_functorI' 𝔎23_is_functor)
      (auto intro!: cat_small_cs_intros)
qed

lemma (in 𝒵) 𝔎23_is_tiny_functor'[cat_Kan_cs_intros]:
  assumes "𝔄' = cat_ordinal (2)"
    and "𝔅' = cat_ordinal (3)"
  shows "𝔎23 : 𝔄' ↦↦C.tinyα 𝔅'"
  unfolding assms by (rule 𝔎23_is_tiny_functor)

lemmas [cat_Kan_cs_intros] = 𝒵.𝔎23_is_tiny_functor'



subsectionLK23›: the functor associated with the left Kan extension along const‹𝔎23›


subsubsection‹Definition and elementary properties›

definition LK23 :: "V  V"
  where "LK23 𝔉 =
    [
      (
        λacat_ordinal (3)Obj.
         if a = 0  𝔉ObjMap0
          | a = 1  𝔉ObjMap0
          | a = 2  𝔉ObjMap1
          | otherwise  𝔉HomCodObj
      ), 
      (
        λfcat_ordinal (3)Arr.
         if f = [0, 0]  𝔉ArrMap0, 0
          | f = [0, 1]  𝔉ArrMap0, 0
          | f = [0, 2]  𝔉ArrMap0, 1
          | f = [1, 1]  𝔉ArrMap0, 0
          | f = [1, 2]  𝔉ArrMap0, 1
          | f = [2, 2]  𝔉ArrMap1, 1
          | otherwise  𝔉HomCodArr
      ), 
      cat_ordinal (3),
      𝔉HomCod
    ]"


text‹Components.›

lemma LK23_components:
  shows "LK23 𝔉ObjMap =
    (
      λacat_ordinal (3)Obj.
        if a = 0  𝔉ObjMap0
         | a = 1  𝔉ObjMap0
         | a = 2  𝔉ObjMap1
         | otherwise  𝔉HomCodObj
    )"
    and "LK23 𝔉ArrMap =
      (
        λfcat_ordinal (3)Arr.
         if f = [0, 0]  𝔉ArrMap0, 0
          | f = [0, 1]  𝔉ArrMap0, 0
          | f = [0, 2]  𝔉ArrMap0, 1
          | f = [1, 1]  𝔉ArrMap0, 0
          | f = [1, 2]  𝔉ArrMap0, 1
          | f = [2, 2]  𝔉ArrMap1, 1
          | otherwise  𝔉HomCodArr
      )"
    and "LK23 𝔉HomDom = cat_ordinal (3)"
    and "LK23 𝔉HomCod = 𝔉HomCod"
  unfolding LK23_def dghm_field_simps by (simp_all add: nat_omega_simps)

context is_functor
begin

lemmas LK23_components' = LK23_components[where 𝔉=𝔉, unfolded cat_cs_simps]

lemmas [cat_Kan_cs_simps] = LK23_components'(3,4)

end

lemmas [cat_Kan_cs_simps] = is_functor.LK23_components'(3,4)


subsubsection‹Object map›

mk_VLambda LK23_components(1)
  |vsv LK23_ObjMap_vsv[cat_Kan_cs_intros]|
  |vdomain LK23_ObjMap_vdomain[cat_Kan_cs_simps]|
  |app LK23_ObjMap_app|

lemma LK23_ObjMap_app_0[cat_Kan_cs_simps]:
  assumes "a = 0"
  shows "LK23 𝔉ObjMapa = 𝔉ObjMap0"
  unfolding LK23_components assms cat_ordinal_components by simp

lemma LK23_ObjMap_app_1[cat_Kan_cs_simps]:
  assumes "a = 1"
  shows "LK23 𝔉ObjMapa = 𝔉ObjMap0"
  unfolding LK23_components assms cat_ordinal_components by simp

lemma LK23_ObjMap_app_2[cat_Kan_cs_simps]:
  assumes "a = 2"
  shows "LK23 𝔉ObjMapa = 𝔉ObjMap1"
  unfolding LK23_components assms cat_ordinal_components by simp


subsubsection‹Arrow map›

mk_VLambda LK23_components(2)
  |vsv LK23_ArrMap_vsv[cat_Kan_cs_intros]|
  |vdomain LK23_ArrMap_vdomain[cat_Kan_cs_simps]|
  |app LK23_ArrMap_app|

lemma LK23_ArrMap_app_00[cat_Kan_cs_simps]:
  assumes "f = [0, 0]"
  shows "LK23 𝔉ArrMapf = 𝔉ArrMap0, 0"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding LK23_components assms by auto
qed

lemma LK23_ArrMap_app_01[cat_Kan_cs_simps]:
  assumes "f = [0, 1]"
  shows "LK23 𝔉ArrMapf = 𝔉ArrMap0, 0"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding LK23_components assms by auto
qed

lemma LK23_ArrMap_app_02[cat_Kan_cs_simps]:
  assumes "f = [0, 2]"
  shows "LK23 𝔉ArrMapf = 𝔉ArrMap0, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding LK23_components assms by auto
qed

lemma LK23_ArrMap_app_11[cat_Kan_cs_simps]:
  assumes "f = [1, 1]"
  shows "LK23 𝔉ArrMapf = 𝔉ArrMap0, 0"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding LK23_components assms by auto
qed

lemma LK23_ArrMap_app_12[cat_Kan_cs_simps]:
  assumes "f = [1, 2]"
  shows "LK23 𝔉ArrMapf = 𝔉ArrMap0, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl 
          cs_simp: omega_of_set   
          cs_intro: nat_omega_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding LK23_components assms by auto
qed

lemma LK23_ArrMap_app_22[cat_Kan_cs_simps]:
  assumes "f = [2, 2]"
  shows "LK23 𝔉ArrMapf = 𝔉ArrMap1, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro: 
          nat_omega_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding LK23_components assms by simp
qed


subsubsectionLK23› is a functor›

lemma cat_LK23_is_functor:
  assumes "𝔉 : cat_ordinal (2) ↦↦Cα "
  shows "LK23 𝔉 : cat_ordinal (3) ↦↦Cα "
proof-

  interpret 𝔉: is_functor α ‹cat_ordinal (2)  𝔉 by (rule assms(1))

  from ord_of_nat_ω interpret cat_ordinal_2: finite_category α ‹cat_ordinal (2)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)
  from ord_of_nat_ω interpret cat_ordinal_3: finite_category α ‹cat_ordinal (3)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)

  interpret 𝔉: is_functor α ‹cat_ordinal (2)  𝔉 by (rule assms)

  show ?thesis
  proof(intro is_functorI')
    show "vfsequence (LK23 𝔉)" unfolding LK23_def by auto
    show "vcard (LK23 𝔉) = 4" unfolding LK23_def by (simp add: nat_omega_simps)
    show " (LK23 𝔉ObjMap)  Obj"
    proof(rule vsv.vsv_vrange_vsubset, unfold cat_Kan_cs_simps)
      fix x assume prems: "x  cat_ordinal (3)Obj"
      then consider x = 0 | x = 1 | x = 2
        unfolding cat_ordinal_cs_simps three by auto
      then show "LK23 𝔉ObjMapx  Obj" 
        by cases
          (
            cs_concl 
              cs_simp: cat_Kan_cs_simps cat_ordinal_cs_simps omega_of_set 
              cs_intro: cat_cs_intros nat_omega_intros
          )+
    qed (cs_concl cs_intro: cat_Kan_cs_intros)
    show "LK23 𝔉ArrMapf : LK23 𝔉ObjMapa  LK23 𝔉ObjMapb"
      if "f : a cat_ordinal (3) b" for a b f
    proof-
      from 0123 that show ?thesis
        by (elim cat_ordinal_3_is_arrE; simp only:)
          (
            cs_concl
              cs_simp: cat_Kan_cs_simps
              cs_intro: V_cs_intros cat_cs_intros cat_ordinal_cs_intros
          )+
    qed
    show 
      "LK23 𝔉ArrMapg Acat_ordinal (3) f =
        LK23 𝔉ArrMapg A LK23 𝔉ArrMapf"
      if "g : b cat_ordinal (3) c" and "f : a cat_ordinal (3) b"
      for b c g a f
    proof-
      from 0123 that show ?thesis
        by (elim cat_ordinal_3_is_arrE; simp only:; (solvessimp)?) (*slow*)
          (
            cs_concl 
              cs_simp: 
                cat_ordinal_cs_simps 
                cat_Kan_cs_simps 
                𝔉.cf_ArrMap_Comp[symmetric]
              cs_intro: V_cs_intros cat_cs_intros cat_ordinal_cs_intros
          )+
    qed
    show "LK23 𝔉ArrMapcat_ordinal (3)CIdc = CIdLK23 𝔉ObjMapc"
      if "c  cat_ordinal (3)Obj" for c
    proof-
      from that consider c = 0 | c = 1 | c = 2
        unfolding cat_ordinal_components three by auto
      moreover have "0  2" "1  2" "0  3" "1  3" "2  3" by auto
      ultimately show ?thesis
        by (cases, use nothing in simp_all only:)
          (
            cs_concl 
              cs_simp: 
                cat_ordinal_cs_simps 
                cat_Kan_cs_simps 
                is_functor.cf_ObjMap_CId[symmetric]  
              cs_intro: V_cs_intros cat_cs_intros cat_ordinal_cs_intros
          )+
    qed
  qed 
    (
      cs_concl
        cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed

lemma cat_LK23_is_functor'[cat_Kan_cs_intros]:
  assumes "𝔉 : cat_ordinal (2) ↦↦Cα "
    and "𝔄' = cat_ordinal (3)"
  shows "LK23 𝔉 : 𝔄' ↦↦Cα "
  using assms(1) unfolding assms(2) by (rule cat_LK23_is_functor)


subsubsection‹The fundamental property of LK23›

lemma cf_comp_LK23_𝔎23[cat_Kan_cs_simps]: 
  assumes "𝔉 : cat_ordinal (2) ↦↦Cα "
  shows "LK23 𝔉 CF 𝔎23 = 𝔉"
proof-

  interpret 𝔉: is_functor α ‹cat_ordinal (2)  𝔉 by (rule assms(1))
  interpret 𝔎23: is_functor α ‹cat_ordinal (2) ‹cat_ordinal (3) ‹𝔎23›
    by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
  interpret LK23: is_functor α ‹cat_ordinal (3)  ‹LK23 𝔉
    by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)

  show ?thesis
  proof(rule cf_eqI)
    show "𝔉 : cat_ordinal (2) ↦↦Cα " by (rule assms)
    have ObjMap_dom_lhs: "𝒟 ((LK23 𝔉 CF 𝔎23)ObjMap) = 2"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_ordinal_cs_simps cs_intro: cat_cs_intros
        )
    have ObjMap_dom_rhs: "𝒟 (𝔉ObjMap) = 2"
      by (cs_concl cs_simp: cat_cs_simps cat_ordinal_cs_simps)
    show "(LK23 𝔉 CF 𝔎23)ObjMap = 𝔉ObjMap"
    proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
      fix a assume prems: "a  2"
      then consider a = 0 | a = 1 by force
      then show "(LK23 𝔉 CF 𝔎23)ObjMapa = 𝔉ObjMapa"
        by (cases, use nothing in simp_all only:)
          (
            cs_concl
              cs_simp:
                omega_of_set cat_cs_simps cat_ordinal_cs_simps cat_Kan_cs_simps
              cs_intro: cat_cs_intros nat_omega_intros
          )+
    qed (cs_concl cs_simp: cs_intro: cat_cs_intros V_cs_intros)+
    have ArrMap_dom_lhs: "𝒟 ((LK23 𝔉 CF 𝔎23)ArrMap) = cat_ordinal (2)Arr"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    have ArrMap_dom_rhs: "𝒟 (𝔉ArrMap) = cat_ordinal (2)Arr"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show "(LK23 𝔉 CF 𝔎23)ArrMap = 𝔉ArrMap"
    proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
      fix f assume prems: "f  cat_ordinal (2)Arr"
      then obtain a b where "f : a cat_ordinal (2) b" by auto
      then show "(LK23 𝔉 CF 𝔎23)ArrMapf = 𝔉ArrMapf"
        by (elim cat_ordinal_2_is_arrE; simp only:)
          (
            cs_concl
              cs_simp: cat_cs_simps cat_Kan_cs_simps cs_intro: cat_cs_intros
          )+
    qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros V_cs_intros)+
  qed (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)

qed



subsectionRK23›: the functor associated with the right Kan extension along const‹𝔎23›


subsubsection‹Definition and elementary properties›

definition RK23 :: "V  V"
  where "RK23 𝔉 =
    [
      (
        λacat_ordinal (3)Obj.
         if a = 0  𝔉ObjMap0
          | a = 1  𝔉ObjMap1
          | a = 2  𝔉ObjMap1
          | otherwise  𝔉HomCodObj
      ),
      (
        λfcat_ordinal (3)Arr.
         if f = [0, 0]  𝔉ArrMap0, 0
          | f = [0, 1]  𝔉ArrMap0, 1
          | f = [0, 2]  𝔉ArrMap0, 1
          | f = [1, 1]  𝔉ArrMap1, 1
          | f = [1, 2]  𝔉ArrMap1, 1
          | f = [2, 2]  𝔉ArrMap1, 1
          | otherwise  𝔉HomCodArr
      ), 
      cat_ordinal (3),
      𝔉HomCod
    ]"


text‹Components.›

lemma RK23_components:
  shows "RK23 𝔉ObjMap =
    (
      λacat_ordinal (3)Obj.
        if a = 0  𝔉ObjMap0
         | a = 1  𝔉ObjMap1
         | a = 2  𝔉ObjMap1
         | otherwise  𝔉HomCodObj
    )"
    and "RK23 𝔉ArrMap =
      (
        λfcat_ordinal (3)Arr.
         if f = [0, 0]  𝔉ArrMap0, 0
          | f = [0, 1]  𝔉ArrMap0, 1
          | f = [0, 2]  𝔉ArrMap0, 1
          | f = [1, 1]  𝔉ArrMap1, 1
          | f = [1, 2]  𝔉ArrMap1, 1
          | f = [2, 2]  𝔉ArrMap1, 1
          | otherwise  𝔉HomCodArr
      )"
    and "RK23 𝔉HomDom = cat_ordinal (3)"
    and "RK23 𝔉HomCod = 𝔉HomCod"
  unfolding RK23_def dghm_field_simps by (simp_all add: nat_omega_simps)

context is_functor
begin

lemmas RK23_components' = RK23_components[where 𝔉=𝔉, unfolded cat_cs_simps]

lemmas [cat_Kan_cs_simps] = RK23_components'(3,4)

end

lemmas [cat_Kan_cs_simps] = is_functor.RK23_components'(3,4)


subsubsection‹Object map›

mk_VLambda RK23_components(1)
  |vsv RK23_ObjMap_vsv[cat_Kan_cs_intros]|
  |vdomain RK23_ObjMap_vdomain[cat_Kan_cs_simps]|
  |app RK23_ObjMap_app|

lemma RK23_ObjMap_app_0[cat_Kan_cs_simps]:
  assumes "a = 0"
  shows "RK23 𝔉ObjMapa = 𝔉ObjMap0"
  unfolding RK23_components assms cat_ordinal_components by simp

lemma RK23_ObjMap_app_1[cat_Kan_cs_simps]:
  assumes "a = 1"
  shows "RK23 𝔉ObjMapa = 𝔉ObjMap1"
  unfolding RK23_components assms cat_ordinal_components by simp

lemma RK23_ObjMap_app_2[cat_Kan_cs_simps]:
  assumes "a = 2"
  shows "RK23 𝔉ObjMapa = 𝔉ObjMap1"
  unfolding RK23_components assms cat_ordinal_components by simp


subsubsection‹Arrow map›

mk_VLambda RK23_components(2)
  |vsv RK23_ArrMap_vsv[cat_Kan_cs_intros]|
  |vdomain RK23_ArrMap_vdomain[cat_Kan_cs_simps]|
  |app RK23_ArrMap_app|

lemma RK23_ArrMap_app_00[cat_Kan_cs_simps]:
  assumes "f = [0, 0]"
  shows "RK23 𝔉ArrMapf = 𝔉ArrMap0, 0"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding RK23_components assms by auto
qed

lemma RK23_ArrMap_app_01[cat_Kan_cs_simps]:
  assumes "f = [0, 1]"
  shows "RK23 𝔉ArrMapf = 𝔉ArrMap0, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding RK23_components assms by auto
qed

lemma RK23_ArrMap_app_02[cat_Kan_cs_simps]:
  assumes "f = [0, 2]"
  shows "RK23 𝔉ArrMapf = 𝔉ArrMap0, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding RK23_components assms by auto
qed

lemma RK23_ArrMap_app_11[cat_Kan_cs_simps]:
  assumes "f = [1, 1]"
  shows "RK23 𝔉ArrMapf = 𝔉ArrMap1, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro:
          V_cs_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding RK23_components assms by auto
qed

lemma RK23_ArrMap_app_12[cat_Kan_cs_simps]:
  assumes "f = [1, 2]"
  shows "RK23 𝔉ArrMapf = 𝔉ArrMap1, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl 
          cs_simp: omega_of_set   
          cs_intro: nat_omega_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding RK23_components assms by auto
qed

lemma RK23_ArrMap_app_22[cat_Kan_cs_simps]:
  assumes "f = [2, 2]"
  shows "RK23 𝔉ArrMapf = 𝔉ArrMap1, 1"
proof-
  from 0123 have f: "f  cat_ordinal (3)Arr"
    by 
      (
        cs_concl cs_simp: cs_intro: 
          nat_omega_intros cat_ordinal_cs_intros cat_cs_intros assms
      )
  then show ?thesis unfolding RK23_components assms by simp
qed


subsubsectionRK23› is a functor›

lemma cat_RK23_is_functor:
  assumes "𝔉 : cat_ordinal (2) ↦↦Cα "
  shows "RK23 𝔉 : cat_ordinal (3) ↦↦Cα "
proof-

  interpret 𝔉: is_functor α ‹cat_ordinal (2)  𝔉 by (rule assms(1))

  from ord_of_nat_ω interpret cat_ordinal_2: finite_category α ‹cat_ordinal (2)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)
  from ord_of_nat_ω interpret cat_ordinal_3: finite_category α ‹cat_ordinal (3)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)

  interpret 𝔉: is_functor α ‹cat_ordinal (2)  𝔉 by (rule assms)

  show ?thesis
  proof(intro is_functorI')
    show "vfsequence (RK23 𝔉)" unfolding RK23_def by auto
    show "vcard (RK23 𝔉) = 4" unfolding RK23_def by (simp add: nat_omega_simps)
    show " (RK23 𝔉ObjMap)  Obj"
    proof(rule vsv.vsv_vrange_vsubset, unfold cat_Kan_cs_simps)
      fix x assume prems: "x  cat_ordinal (3)Obj"
      then consider x = 0 | x = 1 | x = 2
        unfolding cat_ordinal_cs_simps three by auto
      then show "RK23 𝔉ObjMapx  Obj" 
        by cases
          (
            cs_concl 
              cs_simp: cat_Kan_cs_simps cat_ordinal_cs_simps omega_of_set 
              cs_intro: cat_cs_intros nat_omega_intros
          )+
    qed (cs_concl cs_intro: cat_Kan_cs_intros)
    show "RK23 𝔉ArrMapf : RK23 𝔉ObjMapa  RK23 𝔉ObjMapb"
      if "f : a cat_ordinal (3) b" for a b f
    proof-
      from 0123 that show ?thesis
        by (elim cat_ordinal_3_is_arrE; simp only:)
          (
            cs_concl
              cs_simp: cat_Kan_cs_simps
              cs_intro: V_cs_intros cat_cs_intros cat_ordinal_cs_intros
          )+
    qed
    show 
      "RK23 𝔉ArrMapg Acat_ordinal (3) f =
        RK23 𝔉ArrMapg A RK23 𝔉ArrMapf"
      if "g : b cat_ordinal (3) c" and "f : a cat_ordinal (3) b"
      for b c g a f
      using 0123 that 
      by (elim cat_ordinal_3_is_arrE; simp only:; (solvessimp)?) (*slow*)
        (
          cs_concl 
            cs_simp: 
              cat_ordinal_cs_simps 
              cat_Kan_cs_simps 
              𝔉.cf_ArrMap_Comp[symmetric]
            cs_intro: V_cs_intros cat_cs_intros cat_ordinal_cs_intros
        )+
    show "RK23 𝔉ArrMapcat_ordinal (3)CIdc = CIdRK23 𝔉ObjMapc"
      if "c  cat_ordinal (3)Obj" for c
    proof-
      from that consider c = 0 | c = 1 | c = 2
        unfolding cat_ordinal_components three by auto
      then show ?thesis
        by (cases, use 0123 in simp_all only:)
          (
            cs_concl
              cs_simp: 
                cat_ordinal_cs_simps 
                cat_Kan_cs_simps 
                is_functor.cf_ObjMap_CId[symmetric]  
              cs_intro: V_cs_intros cat_cs_intros cat_ordinal_cs_intros
          )+
    qed
  qed 
    (
      cs_concl
        cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed

lemma cat_RK23_is_functor'[cat_Kan_cs_intros]:
  assumes "𝔉 : cat_ordinal (2) ↦↦Cα "
    and "𝔄' = cat_ordinal (3)"
  shows "RK23 𝔉 : 𝔄' ↦↦Cα "
  using assms(1) unfolding assms(2) by (rule cat_RK23_is_functor)


subsubsection‹The fundamental property of RK23›

lemma cf_comp_RK23_𝔎23[cat_Kan_cs_simps]: 
  assumes "𝔉 : cat_ordinal (2) ↦↦Cα "
  shows "RK23 𝔉 CF 𝔎23 = 𝔉"
proof-

  interpret 𝔉: is_functor α ‹cat_ordinal (2)  𝔉 by (rule assms(1))
  interpret 𝔎23: is_functor α ‹cat_ordinal (2) ‹cat_ordinal (3) ‹𝔎23›
    by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
  interpret RK23: is_functor α ‹cat_ordinal (3)  ‹RK23 𝔉
    by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)

  show ?thesis
  proof(rule cf_eqI)
    show "𝔉 : cat_ordinal (2) ↦↦Cα " by (rule assms)
    have ObjMap_dom_lhs: "𝒟 ((RK23 𝔉 CF 𝔎23)ObjMap) = 2"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_ordinal_cs_simps cs_intro: cat_cs_intros
        )
    have ObjMap_dom_rhs: "𝒟 (𝔉ObjMap) = 2"
      by (cs_concl cs_simp: cat_cs_simps cat_ordinal_cs_simps)
    show "(RK23 𝔉 CF 𝔎23)ObjMap = 𝔉ObjMap"
    proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
      fix a assume prems: "a  2"
      then consider a = 0 | a = 1 by force
      then show "(RK23 𝔉 CF 𝔎23)ObjMapa = 𝔉ObjMapa"
        by (cases, use nothing in simp_all only:)
          (
            cs_concl
              cs_simp:
                omega_of_set cat_cs_simps cat_ordinal_cs_simps cat_Kan_cs_simps
              cs_intro: cat_cs_intros nat_omega_intros
          )+
    qed (cs_concl cs_simp: cs_intro: cat_cs_intros V_cs_intros)+
    have ArrMap_dom_lhs: "𝒟 ((RK23 𝔉 CF 𝔎23)ArrMap) = cat_ordinal (2)Arr"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    have ArrMap_dom_rhs: "𝒟 (𝔉ArrMap) = cat_ordinal (2)Arr"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show "(RK23 𝔉 CF 𝔎23)ArrMap = 𝔉ArrMap"
    proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
      fix f assume prems: "f  cat_ordinal (2)Arr"
      then obtain a b where "f : a cat_ordinal (2) b" by auto
      then show "(RK23 𝔉 CF 𝔎23)ArrMapf = 𝔉ArrMapf"
        by (elim cat_ordinal_2_is_arrE; simp only:)
          (
            cs_concl
              cs_simp: cat_cs_simps cat_Kan_cs_simps cs_intro: cat_cs_intros
          )+
    qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros V_cs_intros)+
  qed (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)

qed



subsectionRK_σ23›: towards the universal property of the right Kan extension along 𝔎23›


subsubsection‹Definition and elementary properties›

definition RK_σ23 :: "V  V  V  V"
  where "RK_σ23 𝔗 ε' 𝔉' =
    [
      (
        λacat_ordinal (3)Obj.
         if a = 0  ε'NTMap0
          | a = 1  ε'NTMap1 A𝔗HomCod 𝔉'ArrMap1, 2
          | a = 2  ε'NTMap1
          | otherwise  𝔗HomCodArr
      ),
      𝔉',
      RK23 𝔗,
      cat_ordinal (3),
      𝔉'HomCod
    ]"


text‹Components.›

lemma RK_σ23_components:
  shows "RK_σ23 𝔗 ε' 𝔉'NTMap =
    (
      λacat_ordinal (3)Obj.
        if a = 0  ε'NTMap0
         | a = 1  ε'NTMap1 A𝔗HomCod 𝔉'ArrMap1, 2
         | a = 2  ε'NTMap1
         | otherwise  𝔗HomCodArr
    )"
    and "RK_σ23 𝔗 ε' 𝔉'NTDom = 𝔉'"
    and "RK_σ23 𝔗 ε' 𝔉'NTCod = RK23 𝔗"
    and "RK_σ23 𝔗 ε' 𝔉'NTDGDom = cat_ordinal (3)"
    and "RK_σ23 𝔗 ε' 𝔉'NTDGCod = 𝔉'HomCod"
  unfolding RK_σ23_def nt_field_simps by (simp_all add: nat_omega_simps)

context
  fixes α 𝔄 𝔉' 𝔗  
  assumes 𝔉': "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
    and 𝔗: "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
begin

interpretation 𝔉': is_functor α ‹cat_ordinal (3) 𝔄 𝔉' by (rule 𝔉')
interpretation 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule 𝔗)

lemmas RK_σ23_components' = 
  RK_σ23_components[where 𝔉'=𝔉' and 𝔗=𝔗, unfolded cat_cs_simps]

lemmas [cat_Kan_cs_simps] = RK_σ23_components'(2-5)

end


subsubsection‹Natural transformation map›

mk_VLambda RK_σ23_components(1)
  |vsv RK_σ23_NTMap_vsv[cat_Kan_cs_intros]|
  |vdomain RK_σ23_NTMap_vdomain[cat_Kan_cs_simps]|
  |app RK_σ23_NTMap_app|

lemma RK_σ23_NTMap_app_0[cat_Kan_cs_simps]:
  assumes "a = 0"
  shows "RK_σ23 𝔗 ε' 𝔉'NTMapa = ε'NTMap0"
  using assms unfolding RK_σ23_components cat_ordinal_cs_simps by simp

lemma (in is_functor) RK_σ23_NTMap_app_1[cat_Kan_cs_simps]:
  assumes "a = 1"
  shows "RK_σ23 𝔉 ε' 𝔉'NTMapa = ε'NTMap1 A𝔅 𝔉'ArrMap1, 2"
  using assms 
  unfolding RK_σ23_components cat_ordinal_cs_simps cat_cs_simps 
  by simp

lemmas [cat_Kan_cs_simps] = is_functor.RK_σ23_NTMap_app_1

lemma RK_σ23_NTMap_app_2[cat_Kan_cs_simps]:
  assumes "a = 2"
  shows "RK_σ23 𝔗 ε' 𝔉'NTMapa = ε'NTMap1"
  using assms unfolding RK_σ23_components cat_ordinal_cs_simps by simp


subsubsectionRK_σ23› is a natural transformation›

lemma RK_σ23_is_ntcf:
  assumes "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄" 
    and "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
    and "ε' : 𝔉' CF 𝔎23 CF 𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
  shows "RK_σ23 𝔗 ε' 𝔉' : 𝔉' CF RK23 𝔗 : cat_ordinal (3) ↦↦Cα 𝔄"
proof-
 
  interpret 𝔉': is_functor α ‹cat_ordinal (3) 𝔄 𝔉' by (rule assms(1))
  interpret 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule assms(2))
  interpret ε': is_ntcf α ‹cat_ordinal (2) 𝔄 𝔉' CF 𝔎23› 𝔗 ε' 
    by (rule assms(3))

  interpret 𝔎23: is_functor α ‹cat_ordinal (2) ‹cat_ordinal (3) ‹𝔎23›
    by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
  interpret RK23: is_functor α ‹cat_ordinal (3) 𝔄 ‹RK23 𝔗
    by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)

  from 0123 have [cat_cs_simps]: "𝔗ArrMap1, 1 = 𝔄CId𝔗ObjMap1"
    by 
      (
        cs_concl 
          cs_simp: cat_ordinal_cs_simps is_functor.cf_ObjMap_CId[symmetric] 
          cs_intro: cat_cs_intros
      )

  show ?thesis
  proof(rule is_ntcfI')
    show "vfsequence (RK_σ23 𝔗 ε' 𝔉')" unfolding RK_σ23_def by simp
    show "vcard (RK_σ23 𝔗 ε' 𝔉') = 5"
      unfolding RK_σ23_def by (simp_all add: nat_omega_simps)
    show "RK_σ23 𝔗 ε' 𝔉'NTMapa : 𝔉'ObjMapa 𝔄 RK23 𝔗ObjMapa"
      if "a  cat_ordinal (3)Obj" for a
    proof-
      from that consider a = 0 | a = 1 | a = 2
        unfolding cat_ordinal_cs_simps three by auto
      from this 0123 show ?thesis
        by (cases, use nothing in simp_all only:)
          (
            cs_concl
              cs_simp: cat_cs_simps cat_ordinal_cs_simps cat_Kan_cs_simps
              cs_intro:
                cat_cs_intros
                cat_ordinal_cs_intros
                cat_Kan_cs_intros 
                nat_omega_intros
          )+
    qed
    show
      "RK_σ23 𝔗 ε' 𝔉'NTMapb A𝔄 𝔉'ArrMapf =
        RK23 𝔗ArrMapf A𝔄 RK_σ23 𝔗 ε' 𝔉'NTMapa"
      if "f : a cat_ordinal (3) b" for a b f
      using that 0123
      by  (elim cat_ordinal_3_is_arrE, use nothing in simp_all only:) (*slow*)
        (
          cs_concl
            cs_simp:
              cat_cs_simps
              cat_ordinal_cs_simps
              𝔉'.cf_ArrMap_Comp[symmetric]
              𝔉'.HomCod.cat_Comp_assoc
              ε'.ntcf_Comp_commute[symmetric]
              cat_Kan_cs_simps 
            cs_intro: cat_cs_intros cat_ordinal_cs_intros nat_omega_intros
        )+
  qed
    (
      cs_concl
        cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed

lemma RK_σ23_is_ntcf'[cat_Kan_cs_intros]:
  assumes "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄" 
    and "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
    and "ε' : 𝔉' CF 𝔎23 CF 𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
    and "𝔊' = 𝔉'"
    and "ℌ' = RK23 𝔗"
    and "ℭ' = cat_ordinal (3)"
  shows "RK_σ23 𝔗 ε' 𝔉' : 𝔊' CF ℌ': ℭ' ↦↦Cα 𝔄"
  using assms(1-3) unfolding assms(4-6) by (rule RK_σ23_is_ntcf)



subsection‹The right Kan extension along 𝔎23›

lemma ε23_is_cat_rKe:
  assumes "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
  shows "ntcf_id 𝔗 :
    RK23 𝔗 CF 𝔎23 CF.rKeα 𝔗 : cat_ordinal (2) C cat_ordinal (3) C 𝔄"
proof-

  interpret 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule assms(1))
  interpret 𝔎23: is_functor α ‹cat_ordinal (2) ‹cat_ordinal (3) ‹𝔎23›
    by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
  interpret RK23: is_functor α ‹cat_ordinal (3) 𝔄 ‹RK23 𝔗
    by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)

  from 0123 have [cat_cs_simps]: "𝔗ArrMap1, 1 = 𝔄CId𝔗ObjMap1"
    by
      (
        cs_concl
          cs_simp: cat_ordinal_cs_simps is_functor.cf_ObjMap_CId[symmetric]
          cs_intro: cat_cs_intros
      )

  show ?thesis
  proof(intro is_cat_rKeI')
    
    fix 𝔉' ε' assume prems:
      "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
      "ε' : 𝔉' CF 𝔎23 CF 𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"

    interpret 𝔉': is_functor α ‹cat_ordinal (3) 𝔄 𝔉' by (rule prems(1))
    interpret ε': is_ntcf α ‹cat_ordinal (2) 𝔄 𝔉' CF 𝔎23› 𝔗 ε' 
      by (rule prems(2))
    interpret RK_σ23: is_ntcf α ‹cat_ordinal (3) 𝔄 𝔉' ‹RK23 𝔗 ‹RK_σ23 𝔗 ε' 𝔉'
      by (intro RK_σ23_is_ntcf prems assms)

    show "∃!σ.
      σ : 𝔉' CF RK23 𝔗 : cat_ordinal (3) ↦↦Cα 𝔄 
      ε' = ntcf_id 𝔗 NTCF (σ NTCF-CF 𝔎23)"
    proof(intro ex1I conjI; (elim conjE)?)
      show "RK_σ23 𝔗 ε' 𝔉' : 𝔉' CF RK23 𝔗 : cat_ordinal (3) ↦↦Cα 𝔄"
        by (intro RK_σ23.is_ntcf_axioms)
      show "ε' = ntcf_id 𝔗 NTCF (RK_σ23 𝔗 ε' 𝔉' NTCF-CF 𝔎23)"
      proof(rule ntcf_eqI)
        show "ε' : 𝔉' CF 𝔎23 CF 𝔗 : cat_ordinal (2) ↦↦Cα 𝔄" 
          by (intro prems)
        then have dom_lhs: "𝒟 (ε'NTMap) = 2"
          by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
        show rhs:
          "ntcf_id 𝔗 NTCF (RK_σ23 𝔗 ε' 𝔉' NTCF-CF 𝔎23) :
            𝔉' CF 𝔎23 CF 𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
          by
            (
              cs_concl 
                cs_simp: cat_Kan_cs_simps cat_cs_simps 
                cs_intro: cat_Kan_cs_intros cat_cs_intros
            )
        then have dom_rhs: 
          "𝒟 ((ntcf_id 𝔗 NTCF (RK_σ23 𝔗 ε' 𝔉' NTCF-CF 𝔎23))NTMap) = 2"
          by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
        show "ε'NTMap = (ntcf_id 𝔗 NTCF (RK_σ23 𝔗 ε' 𝔉' NTCF-CF 𝔎23))NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix a assume prems: "a  2"
          then consider a = 0 | a = 1 unfolding two by auto
          then show 
            "ε'NTMapa =
              (ntcf_id 𝔗 NTCF (RK_σ23 𝔗 ε' 𝔉' NTCF-CF 𝔎23))NTMapa"
            by (cases; use nothing in simp_all only:)
              (
                cs_concl
                  cs_simp:
                    omega_of_set
                    cat_Kan_cs_simps
                    cat_cs_simps
                    cat_ordinal_cs_simps
                  cs_intro: cat_Kan_cs_intros cat_cs_intros nat_omega_intros
              )+
        qed (use rhs in cs_concl cs_simp: cs_intro: V_cs_intros cat_cs_intros)+
      qed simp_all

      fix σ assume prems': 
        "σ : 𝔉' CF RK23 𝔗 : cat_ordinal (3) ↦↦Cα 𝔄"
        "ε' = ntcf_id 𝔗 NTCF (σ NTCF-CF 𝔎23)"

      interpret σ: is_ntcf α ‹cat_ordinal (3) 𝔄 𝔉' ‹RK23 𝔗 σ 
        by (rule prems'(1))

      from prems'(2) have 
        "ε'NTMap0 = (ntcf_id 𝔗 NTCF (σ NTCF-CF 𝔎23))NTMap0"
        by auto
      then have [cat_cs_simps]: "ε'NTMap0 = σNTMap0"
        by
          (
            cs_prems
              cs_simp: cat_Kan_cs_simps cat_cs_simps cat_ordinal_cs_simps 
              cs_intro: cat_cs_intros nat_omega_intros
          )
      from prems'(2) have
        "ε'NTMap1 = (ntcf_id 𝔗 NTCF (σ NTCF-CF 𝔎23))NTMap1"
        by auto
      then have [cat_cs_simps]: "ε'NTMap1 = σNTMap2"
        by
          (
            cs_prems
              cs_simp:
                omega_of_set cat_Kan_cs_simps cat_cs_simps cat_ordinal_cs_simps
              cs_intro: cat_cs_intros nat_omega_intros
          )

      show "σ = RK_σ23 𝔗 ε' 𝔉'"
      proof(rule ntcf_eqI)
        show "σ : 𝔉' CF RK23 𝔗 : cat_ordinal (3) ↦↦Cα 𝔄"
          by (rule prems'(1))
        then have dom_lhs: "𝒟 (σNTMap) = 3"
          by (cs_concl cs_simp: cat_cs_simps cat_ordinal_cs_simps)
        show "RK_σ23 𝔗 ε' 𝔉' : 𝔉' CF RK23 𝔗 : cat_ordinal (3) ↦↦Cα 𝔄"
          by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
        then have dom_rhs: "𝒟 (RK_σ23 𝔗 ε' 𝔉'NTMap) = 3"
          by (cs_concl cs_simp: cat_cs_simps cat_ordinal_cs_simps)
        from 0123 have 013: "[0, 1] : 0 cat_ordinal (3) 1"
          by (cs_concl cs_simp: cs_intro: cat_ordinal_cs_intros nat_omega_intros)
        from 0123 have 123: "[1, 2] : 1 cat_ordinal (3) 2"
          by (cs_concl cs_simp: cs_intro: cat_ordinal_cs_intros nat_omega_intros)

        from σ.ntcf_Comp_commute[OF 123] 013 0123 
        have [symmetric, cat_Kan_cs_simps]:
          "σNTMap2 A𝔄 𝔉'ArrMap 1, 2 = σNTMap1"
          by
            (
              cs_prems 
                cs_simp: cat_cs_simps cat_Kan_cs_simps RK23_ArrMap_app_12 
                cs_intro: cat_cs_intros
            )
        show "σNTMap = RK_σ23 𝔗 ε' 𝔉'NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix a assume prems: "a  3"
          then consider a = 0 | a = 1 | a = 2 unfolding three by auto
          then show "σNTMapa = RK_σ23 𝔗 ε' 𝔉'NTMapa"
            by (cases; use nothing in simp_all only:) 
              (cs_concl cs_simp: cat_cs_simps cat_Kan_cs_simps)+
        qed auto
      qed simp_all

    qed

  qed (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)+

qed



subsectionLK_σ23›: towards the universal property of the left Kan extension along 𝔎23›


subsubsection‹Definition and elementary properties›

definition LK_σ23 :: "V  V  V  V"
  where "LK_σ23 𝔗 η' 𝔉' =
    [
      (
        λacat_ordinal (3)Obj.
         if a = 0  η'NTMap0
          | a = 1  𝔉'ArrMap0, 1 A𝔗HomCod η'NTMap0
          | a = 2  η'NTMap1
          | otherwise  𝔗HomCodArr
      ),
      LK23 𝔗,
      𝔉',
      cat_ordinal (3),
      𝔉'HomCod
    ]"


text‹Components.›

lemma LK_σ23_components:
  shows "LK_σ23 𝔗 η' 𝔉'NTMap =
    (
      λacat_ordinal (3)Obj.
        if a = 0  η'NTMap0
         | a = 1  𝔉'ArrMap0, 1 A𝔗HomCod η'NTMap0
         | a = 2  η'NTMap1
         | otherwise  𝔗HomCodArr
    )"
    and "LK_σ23 𝔗 η' 𝔉'NTDom = LK23 𝔗"
    and "LK_σ23 𝔗 η' 𝔉'NTCod = 𝔉'"
    and "LK_σ23 𝔗 η' 𝔉'NTDGDom = cat_ordinal (3)"
    and "LK_σ23 𝔗 η' 𝔉'NTDGCod = 𝔉'HomCod"
  unfolding LK_σ23_def nt_field_simps by (simp_all add: nat_omega_simps)

context
  fixes α 𝔄 𝔉' 𝔗  
  assumes 𝔉': "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
    and 𝔗: "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
begin

interpretation 𝔉': is_functor α ‹cat_ordinal (3) 𝔄 𝔉' by (rule 𝔉')
interpretation 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule 𝔗)

lemmas LK_σ23_components' = 
  LK_σ23_components[where 𝔉'=𝔉' and 𝔗=𝔗, unfolded cat_cs_simps]

lemmas [cat_Kan_cs_simps] = LK_σ23_components'(2-5)

end


subsubsection‹Natural transformation map›

mk_VLambda LK_σ23_components(1)
  |vsv LK_σ23_NTMap_vsv[cat_Kan_cs_intros]|
  |vdomain LK_σ23_NTMap_vdomain[cat_Kan_cs_simps]|
  |app LK_σ23_NTMap_app|

lemma LK_σ23_NTMap_app_0[cat_Kan_cs_simps]:
  assumes "a = 0"
  shows "LK_σ23 𝔗 η' 𝔉'NTMapa = η'NTMap0"
  using assms unfolding LK_σ23_components cat_ordinal_cs_simps by simp

lemma (in is_functor) LK_σ23_NTMap_app_1[cat_Kan_cs_simps]:
  assumes "a = 1"
  shows "LK_σ23 𝔉 η' 𝔉'NTMapa = 𝔉'ArrMap0, 1 A𝔅 η'NTMap0"
  using assms unfolding LK_σ23_components cat_ordinal_cs_simps cat_cs_simps by simp

lemmas [cat_Kan_cs_simps] = is_functor.LK_σ23_NTMap_app_1

lemma LK_σ23_NTMap_app_2[cat_Kan_cs_simps]:
  assumes "a = 2"
  shows "LK_σ23 𝔗 η' 𝔉'NTMapa = η'NTMap1"
  using assms unfolding LK_σ23_components cat_ordinal_cs_simps by simp


subsubsectionLK_σ23› is a natural transformation›

lemma LK_σ23_is_ntcf:
  assumes "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄" 
    and "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
    and "η' : 𝔗 CF 𝔉' CF 𝔎23 : cat_ordinal (2) ↦↦Cα 𝔄"
  shows "LK_σ23 𝔗 η' 𝔉' : LK23 𝔗 CF 𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
proof-
 
  interpret 𝔉': is_functor α ‹cat_ordinal (3) 𝔄 𝔉' by (rule assms(1))
  interpret 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule assms(2))
  interpret η': is_ntcf α ‹cat_ordinal (2) 𝔄 𝔗 𝔉' CF 𝔎23› η' 
    by (rule assms(3))

  interpret 𝔎23: is_functor α ‹cat_ordinal (2) ‹cat_ordinal (3) ‹𝔎23›
    by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
  interpret LK23: is_functor α ‹cat_ordinal (3) 𝔄 ‹LK23 𝔗
    by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)
 
  show ?thesis
  proof(rule is_ntcfI')
    show "vfsequence (LK_σ23 𝔗 η' 𝔉')" unfolding LK_σ23_def by simp
    show "vcard (LK_σ23 𝔗 η' 𝔉') = 5"
      unfolding LK_σ23_def by (simp_all add: nat_omega_simps)
    show "LK_σ23 𝔗 η' 𝔉'NTMapa : LK23 𝔗ObjMapa 𝔄 𝔉'ObjMapa"
      if "a  cat_ordinal (3)Obj" for a
    proof-
      from that consider a = 0 | a = 1 | a = 2
        unfolding cat_ordinal_cs_simps three by auto
      from this 0123 show 
        "LK_σ23 𝔗 η' 𝔉'NTMapa : LK23 𝔗ObjMapa 𝔄 𝔉'ObjMapa"
        by (cases, use nothing in simp_all only:)
          (
            cs_concl
              cs_simp: cat_cs_simps cat_ordinal_cs_simps cat_Kan_cs_simps
              cs_intro:
                cat_cs_intros 
                cat_ordinal_cs_intros 
                cat_Kan_cs_intros
                nat_omega_intros
          )+
    qed
    show
      "LK_σ23 𝔗 η' 𝔉'NTMapb A𝔄 LK23 𝔗ArrMapf =
        𝔉'ArrMapf A𝔄 LK_σ23 𝔗 η' 𝔉'NTMapa"
      if "f : a cat_ordinal (3) b" for a b f
      using that 0123 
      by (elim cat_ordinal_3_is_arrE, use nothing in simp_all only:) (*slow*)
        (
          cs_concl
            cs_simp:
              cat_cs_simps
              cat_ordinal_cs_simps
              𝔉'.cf_ArrMap_Comp[symmetric]
              𝔉'.HomCod.cat_Comp_assoc[symmetric]
              η'.ntcf_Comp_commute
              cat_Kan_cs_simps
            cs_intro: cat_cs_intros cat_ordinal_cs_intros nat_omega_intros
        )+
  qed
    (
      cs_concl
        cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros cat_Kan_cs_intros
    )+

qed

lemma LK_σ23_is_ntcf'[cat_Kan_cs_intros]:
  assumes "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
    and "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
    and "η' : 𝔗 CF 𝔉' CF 𝔎23 : cat_ordinal (2) ↦↦Cα 𝔄"
    and "𝔊' = LK23 𝔗"
    and "ℌ' = 𝔉'"
    and "ℭ' = cat_ordinal (3)"
  shows "LK_σ23 𝔗 η' 𝔉' : 𝔊' CF ℌ': ℭ' ↦↦Cα 𝔄"
  using assms(1-3) unfolding assms(4-6) by (rule LK_σ23_is_ntcf)



subsection‹The left Kan extension along 𝔎23›

lemma η23_is_cat_rKe:
  assumes "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
  shows "ntcf_id 𝔗 :
    𝔗 CF.lKeα LK23 𝔗 CF 𝔎23 : cat_ordinal (2) C cat_ordinal (3) C 𝔄"
proof-

  interpret 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule assms(1))
  interpret 𝔎23: is_functor α ‹cat_ordinal (2) ‹cat_ordinal (3) ‹𝔎23›
    by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
  interpret LK23: is_functor α ‹cat_ordinal (3) 𝔄 ‹LK23 𝔗
    by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)

  show ?thesis
  proof(intro is_cat_lKeI')
    fix 𝔉' η' assume prems:
      "𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
      "η' : 𝔗 CF 𝔉' CF 𝔎23 : cat_ordinal (2) ↦↦Cα 𝔄"

    interpret 𝔉': is_functor α ‹cat_ordinal (3) 𝔄 𝔉' by (rule prems(1))
    interpret η': is_ntcf α ‹cat_ordinal (2) 𝔄 𝔗 𝔉' CF 𝔎23› η' 
      by (rule prems(2))
    interpret LK_σ23: is_ntcf α ‹cat_ordinal (3) 𝔄 ‹LK23 𝔗 𝔉' ‹LK_σ23 𝔗 η' 𝔉'
      by (intro LK_σ23_is_ntcf prems assms)

    show "∃!σ.
      σ : LK23 𝔗 CF 𝔉' : cat_ordinal (3) ↦↦Cα 𝔄 
      η' = σ NTCF-CF 𝔎23 NTCF ntcf_id 𝔗"
    proof(intro ex1I conjI; (elim conjE)?)
      show "LK_σ23 𝔗 η' 𝔉' : LK23 𝔗 CF 𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
        by (intro LK_σ23.is_ntcf_axioms)
      show "η' = LK_σ23 𝔗 η' 𝔉' NTCF-CF 𝔎23 NTCF ntcf_id 𝔗"
      proof(rule ntcf_eqI)
        show "η' : 𝔗 CF 𝔉' CF 𝔎23 : cat_ordinal (2) ↦↦Cα 𝔄" 
          by (intro prems)
        then have dom_lhs: "𝒟 (η'NTMap) = 2"
          by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
        show rhs:
          "LK_σ23 𝔗 η' 𝔉' NTCF-CF 𝔎23 NTCF ntcf_id 𝔗 :
            𝔗 CF 𝔉' CF 𝔎23 : cat_ordinal (2) ↦↦Cα 𝔄"
          by 
            (
              cs_concl 
                cs_simp: cat_Kan_cs_simps cat_cs_simps 
                cs_intro: cat_Kan_cs_intros cat_cs_intros
            )
        then have dom_rhs: 
          "𝒟 ((LK_σ23 𝔗 η' 𝔉' NTCF-CF 𝔎23 NTCF ntcf_id 𝔗)NTMap) = 2"
          by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
        show "η'NTMap = (LK_σ23 𝔗 η' 𝔉' NTCF-CF 𝔎23 NTCF ntcf_id 𝔗)NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix a assume prems: "a  2"
          then consider a = 0 | a = 1 unfolding two by auto
          then show 
            "η'NTMapa =
              (LK_σ23 𝔗 η' 𝔉' NTCF-CF 𝔎23 NTCF ntcf_id 𝔗)NTMapa"
            by (cases; use nothing in simp_all only:)
              (
                cs_concl 
                  cs_simp: 
                    omega_of_set 
                    cat_Kan_cs_simps 
                    cat_cs_simps 
                    cat_ordinal_cs_simps 
                  cs_intro: cat_Kan_cs_intros cat_cs_intros nat_omega_intros
              )+
        qed (use rhs in cs_concl cs_simp: cs_intro: V_cs_intros cat_cs_intros)+
      qed simp_all

      fix σ assume prems': 
        "σ : LK23 𝔗 CF 𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
        "η' = σ NTCF-CF 𝔎23 NTCF ntcf_id 𝔗"

      interpret σ: is_ntcf α ‹cat_ordinal (3) 𝔄 ‹LK23 𝔗 𝔉' σ 
        by (rule prems'(1))

      from prems'(2) have 
        "η'NTMap0 = (σ NTCF-CF 𝔎23 NTCF ntcf_id 𝔗)NTMap0"
        by auto
      then have [cat_cs_simps]: "η'NTMap0 = σNTMap0"
        by 
          (
            cs_prems 
              cs_simp: cat_Kan_cs_simps cat_cs_simps cat_ordinal_cs_simps 
              cs_intro: cat_cs_intros nat_omega_intros
          )
      from prems'(2) have
        "η'NTMap1 = (σ NTCF-CF 𝔎23 NTCF ntcf_id 𝔗)NTMap1"
        by auto
      then have [cat_cs_simps]: "η'NTMap1 = σNTMap2"
        by
          (
            cs_prems
              cs_simp:
                omega_of_set cat_Kan_cs_simps cat_cs_simps cat_ordinal_cs_simps
              cs_intro: cat_cs_intros nat_omega_intros
          )

      show "σ = LK_σ23 𝔗 η' 𝔉'"
      proof(rule ntcf_eqI)

        show "σ : LK23 𝔗 CF 𝔉' : cat_ordinal (3) ↦↦Cα 𝔄" 
          by (rule prems'(1))
        then have dom_lhs: "𝒟 (σNTMap) = 3"
          by (cs_concl cs_simp: cat_cs_simps cat_ordinal_cs_simps)
        show "LK_σ23 𝔗 η' 𝔉' : LK23 𝔗 CF 𝔉' : cat_ordinal (3) ↦↦Cα 𝔄"
          by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
        then have dom_rhs: "𝒟 (LK_σ23 𝔗 η' 𝔉'NTMap) = 3"
          by (cs_concl cs_simp: cat_cs_simps cat_ordinal_cs_simps)
        from 0123 have 012: "[0, 1] : 0 cat_ordinal (2) 1"
          by (cs_concl cs_simp: cs_intro: cat_ordinal_cs_intros nat_omega_intros)
        from 0123 have 013: "[0, 1] : 0 cat_ordinal (3) 1"
          by (cs_concl cs_simp: cs_intro: cat_ordinal_cs_intros nat_omega_intros)
        from 0123 have 00: "[0, 0] = (cat_ordinal (2))CId0"
          by (cs_concl cs_simp: cat_ordinal_cs_simps)
        from σ.ntcf_Comp_commute[OF 013] 013 0123 
        have [symmetric, cat_Kan_cs_simps]:
          "σNTMap1 = 𝔉'ArrMap0, 1 A𝔄 σNTMap0"
          by
            (
              cs_prems
                cs_simp: cat_cs_simps cat_Kan_cs_simps 00 LK23_ArrMap_app_01
                cs_intro: cat_cs_intros cat_ordinal_cs_intros nat_omega_intros
            )

        show "σNTMap = LK_σ23 𝔗 η' 𝔉'NTMap"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
          fix a assume prems: "a  3"
          then consider a = 0 | a = 1 | a = 2 unfolding three by auto
          then show "σNTMapa = LK_σ23 𝔗 η' 𝔉'NTMapa"
            by (cases; use nothing in simp_all only:) 
              (
                cs_concl 
                  cs_simp: cat_ordinal_cs_simps cat_cs_simps cat_Kan_cs_simps 
                  cs_intro: cat_cs_intros
              )+
        qed auto
      qed simp_all

    qed

  qed (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)+

qed



subsection‹Pointwise Kan extensions along 𝔎23›

lemma ε23_is_cat_pw_rKe:
  assumes "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
  shows "ntcf_id 𝔗 :
    RK23 𝔗 CF 𝔎23 CF.rKe.pwα 𝔗 :
    cat_ordinal (2) C cat_ordinal (3) C 𝔄"
proof-

  interpret 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule assms(1))

  show ?thesis
  proof(intro is_cat_pw_rKeI ε23_is_cat_rKe[OF assms])

    fix a assume prems: "a  𝔄Obj"
    
    show
      "ntcf_id 𝔗 : 
        RK23 𝔗 CF 𝔎23 CF.rKeα 𝔗 :
        cat_ordinal (2) C
        cat_ordinal (3) C
        (HomO.Cα𝔄(a,-) : 𝔄 ↦↦C cat_Set α)"
    proof(intro is_cat_rKe_preservesI ε23_is_cat_rKe[OF assms])
      from prems show "HomO.Cα𝔄(a,-) : 𝔄 ↦↦Cα cat_Set α"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show "HomO.Cα𝔄(a,-) CF-NTCF ntcf_id 𝔗 :
        (HomO.Cα𝔄(a,-) CF RK23 𝔗) CF 𝔎23 CF.rKeα HomO.Cα𝔄(a,-) CF 𝔗 :
        cat_ordinal (2) C cat_ordinal (3) C cat_Set α"
      proof(intro is_cat_rKeI')
        show "𝔎23 : cat_ordinal (2) ↦↦Cα cat_ordinal (3)"
          by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros)
        from prems show
          "HomO.Cα𝔄(a,-) CF RK23 𝔗 : cat_ordinal (3) ↦↦Cα cat_Set α"
          by (cs_concl cs_simp: cs_intro: cat_cs_intros cat_Kan_cs_intros)
        from prems show 
          "HomO.Cα𝔄(a,-) CF-NTCF ntcf_id 𝔗 :
            HomO.Cα𝔄(a,-) CF RK23 𝔗 CF 𝔎23 CF HomO.Cα𝔄(a,-) CF 𝔗 :
            cat_ordinal (2) ↦↦Cα cat_Set α"
          by
            (
              cs_concl
                cs_simp: cat_cs_simps cat_Kan_cs_simps
                cs_intro: cat_cs_intros cat_Kan_cs_intros
            )

        fix 𝔊' ε' assume prems':
          "𝔊' : cat_ordinal (3) ↦↦Cα cat_Set α"
          "ε' :
            𝔊' CF 𝔎23 CF HomO.Cα𝔄(a,-) CF 𝔗 :
            cat_ordinal (2) ↦↦Cα cat_Set α"

        interpret 𝔊': is_functor α ‹cat_ordinal (3) ‹cat_Set α 𝔊' 
          by (rule prems'(1))
        interpret ε': is_ntcf
          α
          ‹cat_ordinal (2)
          ‹cat_Set α
          𝔊' CF 𝔎23›
          HomO.Cα𝔄(a,-) CF 𝔗
          ε'
          by (rule prems'(2))

        show "∃!σ.
          σ :
            𝔊' CF HomO.Cα𝔄(a,-) CF RK23 𝔗 :
            cat_ordinal (3) ↦↦Cα cat_Set α 
          ε' = HomO.Cα𝔄(a,-) CF-NTCF ntcf_id 𝔗 NTCF (σ NTCF-CF 𝔎23)"
        proof(intro ex1I conjI; (elim conjE)?)
          have [cat_Kan_cs_simps]: 
            "HomO.Cα𝔄(a,-) CF RK23 𝔗 = RK23 (HomO.Cα𝔄(a,-) CF 𝔗)"
          proof(rule cf_eqI)
            from prems show lhs: "HomO.Cα𝔄(a,-) CF RK23 𝔗 : 
              cat_ordinal (3) ↦↦Cα cat_Set α"
              by
                (
                  cs_concl
                    cs_simp: cat_cs_simps
                    cs_intro: cat_cs_intros cat_Kan_cs_intros
                )
            from prems show rhs: "RK23 (HomO.Cα𝔄(a,-) CF 𝔗) : 
              cat_ordinal (3) ↦↦Cα cat_Set α"
              by
                (
                  cs_concl
                    cs_simp: cat_cs_simps
                    cs_intro: cat_cs_intros cat_Kan_cs_intros
                )
            from lhs prems have ObjMap_dom_lhs: 
              "𝒟 ((HomO.Cα𝔄(a,-) CF RK23 𝔗)ObjMap) = 3"
              by
                (
                  cs_concl
                    cs_simp: cat_ordinal_cs_simps cat_cs_simps 
                    cs_intro: cat_Kan_cs_intros cat_cs_intros
                )
            from rhs prems have ObjMap_dom_rhs:
              "𝒟 ((RK23 (HomO.Cα𝔄(a,-) CF 𝔗))ObjMap) = 3"
              by 
                (
                  cs_concl 
                    cs_simp: cat_ordinal_cs_simps cat_cs_simps 
                    cs_intro: cat_Kan_cs_intros 
                )
            show 
              "(HomO.Cα𝔄(a,-) CF RK23 𝔗)ObjMap =
                RK23 (HomO.Cα𝔄(a,-) CF 𝔗)ObjMap"
            proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
              fix c assume prems'': "c  3"
              with 0123 consider c = 0 | c = 1 | c = 2 by force
              from this prems prems'' 0123 show 
                "(HomO.Cα𝔄(a,-) CF RK23 𝔗)ObjMapc =
                  RK23 (HomO.Cα𝔄(a,-) CF 𝔗)ObjMapc"
                by (cases; use nothing in simp_all only:)
                  (
                    cs_concl
                      cs_simp:
                        cat_ordinal_cs_simps
                        cat_cs_simps
                        cat_op_simps
                        cat_Kan_cs_simps
                      cs_intro: cat_Kan_cs_intros cat_cs_intros
                 )+
            qed 
              (
                use prems in cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros
              )+
            from lhs prems have ArrMap_dom_lhs: 
              "𝒟 ((HomO.Cα𝔄(a,-) CF RK23 𝔗)ArrMap) = 
                cat_ordinal (3)Arr"
              by
                (
                  cs_concl
                    cs_simp: cat_ordinal_cs_simps cat_cs_simps 
                    cs_intro: cat_Kan_cs_intros cat_cs_intros
                )
            from rhs prems have ArrMap_dom_rhs:
              "𝒟 ((RK23 (HomO.Cα𝔄(a,-) CF 𝔗))ArrMap) = 
                cat_ordinal (3)Arr"
              by 
                (
                  cs_concl 
                    cs_simp: cat_ordinal_cs_simps cat_cs_simps 
                    cs_intro: cat_Kan_cs_intros 
                )
            show 
              "(HomO.Cα𝔄(a,-) CF RK23 𝔗)ArrMap =
                RK23 (HomO.Cα𝔄(a,-) CF 𝔗)ArrMap"
            proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
              fix f assume prems'': "f  cat_ordinal (3)Arr"
              then obtain a' b' where "f : a' cat_ordinal (3) b'" by auto
              from this 0123 prems show 
                "(HomO.Cα𝔄(a,-) CF RK23 𝔗)ArrMapf =
                  RK23 (HomO.Cα𝔄(a,-) CF 𝔗)ArrMapf"
                by (*slow*)
                  (
                    elim cat_ordinal_3_is_arrE;
                    use nothing in simp_all only:
                  )
                  (
                    cs_concl
                      cs_simp: cat_cs_simps cat_Kan_cs_simps cat_op_simps
                      cs_intro:
                        cat_ordinal_cs_intros
                        cat_Kan_cs_intros
                        cat_cs_intros
                        nat_omega_intros
                  )+
            qed 
              (
                use prems in 
                  cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros
              )+
          qed simp_all

          show "RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊' : 
            𝔊' CF HomO.Cα𝔄(a,-) CF RK23 𝔗 : 
            cat_ordinal (3) ↦↦Cα cat_Set α"
            by (intro RK_σ23_is_ntcf')
              (cs_concl cs_simp: cat_Kan_cs_simps cs_intro: cat_cs_intros)+
          show "ε' = 
            HomO.Cα𝔄(a,-) CF-NTCF 
            ntcf_id 𝔗 NTCF 
            (RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊' NTCF-CF 𝔎23)"
          proof(rule ntcf_eqI)
            show "ε' :
              𝔊' CF 𝔎23 CF HomO.Cα𝔄(a,-) CF 𝔗 :
              cat_ordinal (2) ↦↦Cα cat_Set α"
              by (intro prems')
            then have dom_lhs: "𝒟 (ε'NTMap) = 2"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            from prems show 
              "HomO.Cα𝔄(a,-) CF-NTCF 
                ntcf_id 𝔗 NTCF 
                (RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊' NTCF-CF 𝔎23) :
              𝔊' CF 𝔎23 CF HomO.Cα𝔄(a,-) CF 𝔗 :
              cat_ordinal (2) ↦↦Cα cat_Set α"
              by
                (
                  cs_concl
                    cs_simp: cat_Kan_cs_simps
                    cs_intro: cat_Kan_cs_intros cat_cs_intros
                )
            then have dom_rhs: 
              "𝒟 
                (
                  (HomO.Cα𝔄(a,-) CF-NTCF
                  ntcf_id 𝔗 NTCF 
                  (RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊' NTCF-CF 𝔎23)
                )NTMap) = 2"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            show "ε'NTMap =
              (
                HomO.Cα𝔄(a,-) CF-NTCF
                ntcf_id 𝔗 NTCF
                (RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊' NTCF-CF 𝔎23)
              )NTMap"
            proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
              fix c assume prems'': "c  2"
              then consider c = 0 | c = 1 unfolding two by auto
              from this prems 0123 show "ε'NTMapc =
                (
                  HomO.Cα𝔄(a,-) CF-NTCF 
                  ntcf_id 𝔗 NTCF 
                  (RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊' NTCF-CF 𝔎23)
                )NTMapc"
                by (cases; use nothing in simp_all only:)
                  (
                    cs_concl
                      cs_simp: 
                        cat_Kan_cs_simps 
                        cat_ordinal_cs_simps 
                        cat_cs_simps
                        cat_op_simps
                        cat_Set_components(1)
                      cs_intro:
                        cat_Kan_cs_intros
                        cat_cs_intros
                        cat_prod_cs_intros
                        𝔗.HomCod.cat_Hom_in_Vset
                  )+
            qed (cs_concl cs_simp: cs_intro: cat_cs_intros V_cs_intros)+

          qed simp_all

          fix σ assume prems'':
            "σ :
              𝔊' CF HomO.Cα𝔄(a,-) CF RK23 𝔗 :
              cat_ordinal (3) ↦↦Cα cat_Set α"
            "ε' =
              HomO.Cα𝔄(a,-) CF-NTCF ntcf_id 𝔗 NTCF (σ NTCF-CF 𝔎23)"

          interpret σ: is_ntcf 
            α ‹cat_ordinal (3) ‹cat_Set α 𝔊' HomO.Cα𝔄(a,-) CF RK23 𝔗 σ
            by (rule prems''(1))

          from prems''(2) have "ε'NTMap0 =
            (HomO.Cα𝔄(a,-) CF-NTCF ntcf_id 𝔗 NTCF (σ NTCF-CF 𝔎23))NTMap0"
            by auto
          from this prems 0123 have ε'_NTMap_app_0: "ε'NTMap0 = σNTMap0"
            by
              (
                cs_prems
                  cs_simp:
                    cat_ordinal_cs_simps
                    cat_cs_simps
                    cat_Kan_cs_simps
                    cat_op_simps
                    𝔎23_ObjMap_app_0
                    cat_Set_components(1)
                  cs_intro: 
                    cat_Kan_cs_intros
                    cat_cs_intros
                    cat_prod_cs_intros
                    𝔗.HomCod.cat_Hom_in_Vset
              )
          from 0123 have 01: "[0, 1] : 0 cat_ordinal (2) 1"
            by
              (
                cs_concl
                  cs_simp: cat_cs_simps
                  cs_intro: cat_ordinal_cs_intros nat_omega_intros
              )
          from prems''(2) have 
            "ε'NTMap1 =
              (
                HomO.Cα𝔄(a,-) CF-NTCF
                ntcf_id 𝔗 NTCF
                (σ NTCF-CF 𝔎23)
              )NTMap1"
            by auto
          from this prems 0123 have ε'_NTMap_app_1:  
            "ε'NTMap1 = σNTMap2"
            by
              (
                cs_prems
                  cs_simp:
                    cat_ordinal_cs_simps
                    cat_cs_simps
                    cat_Kan_cs_simps
                    cat_op_simps
                    𝔎23_ObjMap_app_1
                    cat_Set_components(1)
                  cs_intro: 
                    cat_Kan_cs_intros
                    cat_cs_intros
                    cat_prod_cs_intros
                    𝔗.HomCod.cat_Hom_in_Vset
              )

          from 0123 have 012: "[0, 1] : 0 cat_ordinal (2) 1"
            by 
              (
                cs_concl cs_simp: cs_intro:
                  cat_ordinal_cs_intros nat_omega_intros
              )
          from 0123 have 013: "[0, 1] : 0 cat_ordinal (3) 1"
            by 
              ( 
                cs_concl cs_simp: cs_intro: 
                  cat_ordinal_cs_intros nat_omega_intros
              )
          from 0123 have 123: "[1, 2] : 1 cat_ordinal (3) 2"
            by 
              (
                cs_concl cs_simp: cs_intro:
                  cat_ordinal_cs_intros nat_omega_intros
              )
          from 0123 have 11: "[1, 1] = (cat_ordinal (2))CId1"
            by (cs_concl cs_simp: cat_ordinal_cs_simps)

          from σ.ntcf_Comp_commute[OF 123] prems 012 013 
          have [cat_Kan_cs_simps]:
            "ε'NTMap1 Acat_Set α 𝔊'ArrMap1, 2 = σNTMap1"
            by (*slow*)
              (
                cs_prems 1
                  cs_simp:
                    cat_cs_simps
                    cat_Kan_cs_simps
                    ε'_NTMap_app_1[symmetric]
                    is_functor.cf_ObjMap_CId
                    RK23_ArrMap_app_12
                    11
                  cs_intro: cat_cs_intros nat_omega_intros 
              )
          
          show "σ = RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊'"
          proof(rule ntcf_eqI)

            show σ: "σ : 
              𝔊' CF HomO.Cα𝔄(a,-) CF RK23 𝔗 : 
              cat_ordinal (3) ↦↦Cα cat_Set α"
              by (rule prems''(1))
            then have dom_lhs: "𝒟 (σNTMap) = 3"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            show "RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊' :
              𝔊' CF HomO.Cα𝔄(a,-) CF RK23 𝔗 : 
              cat_ordinal (3) ↦↦Cα cat_Set α"
              by 
                (
                  cs_concl 
                    cs_simp: cat_Kan_cs_simps 
                    cs_intro: cat_Kan_cs_intros cat_cs_intros
                )
            then have dom_rhs: 
              "𝒟 (RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊'NTMap) = 3"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            show "σNTMap = RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊'NTMap"
            proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
              fix c assume "c  3"
              then consider c = 0 | c = 1 | c = 2  
                unfolding three by auto
              from this 0123 show
                "σNTMapc = RK_σ23 (HomO.Cα𝔄(a,-) CF 𝔗) ε' 𝔊'NTMapc"
                by (cases; use nothing in simp_all only:)
                  (
                    cs_concl cs_simp:
                      cat_Kan_cs_simps ε'_NTMap_app_1 ε'_NTMap_app_0
                  )+
            qed (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros V_cs_intros)+

          qed simp_all

        qed

      qed

    qed

  qed

qed

lemma η23_is_cat_pw_lKe:
  assumes "𝔗 : cat_ordinal (2) ↦↦Cα 𝔄"
  shows "ntcf_id 𝔗 :
    𝔗 CF.lKe.pwα LK23 𝔗 CF 𝔎23 :
    cat_ordinal (2) C cat_ordinal (3) C 𝔄"
proof-

  interpret 𝔗: is_functor α ‹cat_ordinal (2) 𝔄 𝔗 by (rule assms(1))

  from ord_of_nat_ω interpret cat_ordinal_3: finite_category α ‹cat_ordinal (3)
    by (cs_concl cs_intro: cat_ordinal_cs_intros)

  from 0123 have 002: "[0, 0] : 0 cat_ordinal (2) 0"
    by (cs_concl cs_simp: cat_ordinal_cs_simps cs_intro: cat_cs_intros)

  show ?thesis
  proof(intro is_cat_pw_lKeI η23_is_cat_rKe assms, unfold cat_op_simps)
    fix a assume prems: "a  𝔄Obj"
    show 
      "op_ntcf (ntcf_id 𝔗) :
        op_cf (LK23 𝔗) CF op_cf 𝔎23 CF.rKeα op_cf 𝔗 :
        op_cat (cat_ordinal (2)) C op_cat (cat_ordinal (3)) C
        (HomO.Cα𝔄(-,a) : op_cat 𝔄 ↦↦C cat_Set α)"
    proof(intro is_cat_rKe_preservesI)
      show 
        "op_ntcf (ntcf_id 𝔗) :
          op_cf (LK23 𝔗) CF op_cf 𝔎23 CF.rKeα op_cf 𝔗 :
          op_cat (cat_ordinal (2)) C op_cat (cat_ordinal (3)) C op_cat 𝔄"
      proof(cs_intro_step cat_op_intros)
        show "ntcf_id 𝔗 :
          𝔗 CF.lKeα LK23 𝔗 CF 𝔎23 :
          cat_ordinal (2) C cat_ordinal (3) C 𝔄"
          by (intro η23_is_cat_rKe assms)
      qed simp_all
      from prems show "HomO.Cα𝔄(-,a) : op_cat 𝔄 ↦↦Cα cat_Set α"
        by (cs_concl cs_simp: cs_intro: cat_cs_intros)

      have 
        "op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗 :
          op_cf HomO.Cα𝔄(-,a) CF 𝔗 CF.lKeα
          (op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗) CF 𝔎23 :
          cat_ordinal (2) C cat_ordinal (3) C op_cat (cat_Set α)"
      proof(intro is_cat_lKeI')
        show "𝔎23 : cat_ordinal (2) ↦↦Cα cat_ordinal (3)"
          by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros)
        from prems show "op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 :
          cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
          by 
            (
              cs_concl
                cs_simp: cat_cs_simps cat_op_simps 
                cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
            )

        from prems show 
          "op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗 :
            op_cf HomO.Cα𝔄(-,a) CF 𝔗 CF 
            op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 CF 𝔎23 :
            cat_ordinal (2) ↦↦Cα op_cat (cat_Set α)"
          by 
            (
              cs_concl 
                cs_simp: cat_cs_simps cat_Kan_cs_simps cat_op_simps
                cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
            )

        fix 𝔉' η' assume prems':
          "𝔉' : cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
          "η' :
            op_cf HomO.Cα𝔄(-,a) CF 𝔗 CF 𝔉' CF 𝔎23 :
            cat_ordinal (2) ↦↦Cα op_cat (cat_Set α)"

        interpret 𝔉': is_functor α ‹cat_ordinal (3) ‹op_cat (cat_Set α) 𝔉'
          by (rule prems'(1))
        interpret η': is_ntcf
          α
          ‹cat_ordinal (2)
          ‹op_cat (cat_Set α)
          ‹op_cf HomO.Cα𝔄(-,a) CF 𝔗 
          𝔉' CF 𝔎23› 
          η'
          by (rule prems'(2))
        note [unfolded cat_op_simps, cat_cs_intros] = 
          η'.ntcf_NTMap_is_arr'
          𝔉'.cf_ArrMap_is_arr'
        show
          "∃!σ.
            σ :
              op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 CF 𝔉' :
              cat_ordinal (3) ↦↦Cα op_cat (cat_Set α) 
            η' = σ NTCF-CF 𝔎23 NTCF (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗)"
        proof(intro ex1I conjI; (elim conjE)?) 
          have [cat_Kan_cs_simps]:
            "op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 =
              LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗)"
          proof(rule cf_eqI)
            from prems show lhs: "op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 :
              cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
              by
                (
                  cs_concl
                    cs_simp: cat_op_simps
                    cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
                )
            from prems show rhs: "LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) :
              cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
              by (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros cat_cs_intros)
            from lhs prems have ObjMap_dom_lhs:
              "𝒟 ((op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗)ObjMap) = 3"
              by
                (
                  cs_concl
                    cs_simp: cat_ordinal_cs_simps cat_cs_simps cat_op_simps 
                    cs_intro: cat_Kan_cs_intros cat_cs_intros
                )
            from rhs prems have ObjMap_dom_rhs:
              "𝒟 (LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗)ObjMap) = 3"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            show
              "(op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗)ObjMap =
                LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗)ObjMap"
            proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
             fix c assume prems'': "c  3"
             then consider c = 0 | c = 1 | c = 2 
               unfolding three by auto
              from this prems 0123 show 
                "(op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗)ObjMapc =
                  LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗)ObjMapc"
                by (cases; use nothing in simp_all only:)
                  (
                    cs_concl
                      cs_simp:
                        cat_ordinal_cs_simps 
                        cat_Kan_cs_simps 
                        cat_cs_simps 
                        cat_op_simps
                      cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
                  )+
            qed
              (
                use prems in 
                  cs_concl
                      cs_simp: cat_op_simps 
                      cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
              )+

            from lhs prems have ArrMap_dom_lhs:
              "𝒟 ((op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗)ArrMap) = 
                cat_ordinal (3)Arr"
              by
                (
                  cs_concl
                    cs_simp: cat_ordinal_cs_simps cat_cs_simps cat_op_simps 
                    cs_intro: cat_Kan_cs_intros cat_cs_intros
                )
            from rhs prems have ArrMap_dom_rhs:
              "𝒟 (LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗)ArrMap) =
                cat_ordinal (3)Arr"
              by (cs_concl cs_simp: cat_cs_simps)

            show
              "(op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗)ArrMap =
                LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗)ArrMap"
            proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
              fix f assume "f  cat_ordinal (3)Arr"
              then obtain a' b' where f: "f : a' cat_ordinal (3) b'" 
                by auto
              from f prems 0123 002 show
                "(op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗)ArrMapf =
                  LK23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗)ArrMapf"
                by (elim cat_ordinal_3_is_arrE, (simp_all only:)?)
                  (
                    cs_concl
                      cs_simp: cat_cs_simps cat_Kan_cs_simps cat_op_simps 
                      cs_intro: 
                        cat_ordinal_cs_intros 
                        cat_Kan_cs_intros 
                        cat_cs_intros   
                        cat_op_intros 
                        nat_omega_intros
                  )+
            qed
              (
                use prems in
                  cs_concl 
                      cs_simp: cat_op_simps
                      cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
              )+
          
          qed simp_all

          show "LK_σ23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉' : 
            op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 CF 𝔉' : 
            cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
            by
              (
                cs_concl 
                  cs_simp: cat_cs_simps cat_Kan_cs_simps cat_op_simps 
                  cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
              )

          show "η' =
            LK_σ23
              (
                op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉' NTCF-CF
                𝔎23 NTCF 
                (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗
              )"
          proof(rule ntcf_eqI)
            show lhs: "η' :
              op_cf HomO.Cα𝔄(-,a) CF 𝔗 CF 𝔉' CF 𝔎23 :
              cat_ordinal (2) ↦↦Cα op_cat (cat_Set α)"
              by (rule prems'(2))
            from lhs have "𝒟 (η'NTMap) = cat_ordinal (2)Obj"
              by (cs_concl cs_simp: cat_cs_simps)
            from prems show rhs: 
              "LK_σ23
                (
                  op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉' NTCF-CF 
                  𝔎23 NTCF 
                  (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗
                ) : 
              op_cf HomO.Cα𝔄(-,a) CF 𝔗 CF 𝔉' CF 𝔎23 :
              cat_ordinal (2) ↦↦Cα op_cat (cat_Set α)"
              by 
                (
                  cs_concl 
                    cs_simp: cat_Kan_cs_simps cat_op_simps 
                    cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
                )
            from lhs have dom_lhs: "𝒟 (η'NTMap) = 2"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            from rhs have dom_rhs: "𝒟 ((LK_σ23
              (
                op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉' NTCF-CF 
                𝔎23 NTCF
                (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗
              ))NTMap) = 2"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            show
              "η'NTMap =
                (
                  LK_σ23
                    (
                      op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉' NTCF-CF
                      𝔎23 NTCF 
                      (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗
                    )
                )NTMap"
            proof(rule vsv_eqI, unfold dom_lhs dom_rhs cat_ordinal_cs_simps)
              fix c assume "c  2"
              then consider c = 0 | c = 1 unfolding two by auto
              from this prems 0123 show 
                "η'NTMapc = 
                  (
                    LK_σ23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉' NTCF-CF 
                    𝔎23 NTCF (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗)
                  )NTMapc"
                by (cases, use nothing in simp_all only:)
                  (
                    cs_concl
                      cs_simp: 
                        cat_ordinal_cs_simps 
                        cat_Kan_cs_simps 
                        cat_cs_simps 
                        cat_op_simps 
                        𝔎23_ObjMap_app_1 
                        𝔎23_ObjMap_app_0 
                        LK_σ23_NTMap_app_0 
                        cat_Set_components(1) 
                      cs_intro: 
                        cat_Kan_cs_intros 
                        cat_cs_intros 
                        cat_prod_cs_intros 
                        cat_op_intros 
                        𝔗.HomCod.cat_Hom_in_Vset
                  )+
            qed (cs_concl cs_simp: cs_intro: V_cs_intros cat_cs_intros)+
          qed simp_all

          fix σ assume prems'':
            "σ : 
              op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 CF 𝔉' : 
              cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
            "η' = σ NTCF-CF 𝔎23 NTCF (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗)"

          interpret σ: is_ntcf 
            α
            ‹cat_ordinal (3) ‹op_cat (cat_Set α) 
            ‹op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 
            𝔉' 
            σ
            by (rule prems''(1))

          note [cat_Kan_cs_intros] = σ.ntcf_NTMap_is_arr'[unfolded cat_op_simps]

          from prems''(2) have 
            "η'NTMap0 =
              (
                σ NTCF-CF
                𝔎23 NTCF
                (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗)
              )NTMap0"
            by simp
          from this prems 0123 have η'_NTMap_app_0: "η'NTMap0 = σNTMap0"
            by (*very slow*) 
              (
                cs_prems 
                  cs_simp: 
                    cat_ordinal_cs_simps
                    cat_Kan_cs_simps 
                    cat_cs_simps 
                    cat_op_simps 
                    cat_Set_components(1)
                  cs_intro: 
                    cat_Kan_cs_intros 
                    cat_cs_intros 
                    cat_prod_cs_intros
                    cat_op_intros 
                    𝔗.HomCod.cat_Hom_in_Vset
              )

          from prems''(2) have 
            "η'NTMap1 =
              (
                σ NTCF-CF
                𝔎23 NTCF
                (op_cf HomO.Cα𝔄(-,a) CF-NTCF ntcf_id 𝔗)
              )NTMap1"
            by simp
          from this prems 0123 have η'_NTMap_app_1: "η'NTMap1 = σNTMap2"
            by (*very slow*) 
              (
                cs_prems
                  cs_simp:
                    cat_ordinal_cs_simps
                    cat_Kan_cs_simps
                    cat_cs_simps
                    cat_op_simps
                    cat_Set_components(1)
                  cs_intro:
                    cat_Kan_cs_intros
                    cat_cs_intros
                    cat_prod_cs_intros
                    cat_op_intros
                    𝔗.HomCod.cat_Hom_in_Vset
              )+

          from 0123 have 013: "[0, 1] : 0 cat_ordinal (3) 1"
            by (cs_concl cs_simp: cs_intro: cat_ordinal_cs_intros nat_omega_intros)
          from 0123 have 00: "[0, 0] = (cat_ordinal (2))CId0"
            by (cs_concl cs_simp: cat_ordinal_cs_simps)

          from σ.ntcf_Comp_commute[OF 013] prems 0123 013
          have [cat_Kan_cs_simps]:
            "σNTMap1 = η'NTMap0 Acat_Set α 𝔉'ArrMap0, 1"
            by
              (
                cs_prems
                  cs_simp:
                    cat_ordinal_cs_simps
                    cat_Kan_cs_simps
                    cat_cs_simps
                    cat_op_simps
                    LK23_ArrMap_app_01
                  cs_intro: 
                    cat_ordinal_cs_intros
                    cat_Kan_cs_intros
                    cat_cs_intros
                    cat_prod_cs_intros
                    cat_op_intros
                    nat_omega_intros
                  cs_simp: 00 η'_NTMap_app_0[symmetric]
              )

          show "σ = LK_σ23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉'"
          proof(rule ntcf_eqI)
            show lhs: "σ :
              op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 CF 𝔉' :
              cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
              by (rule prems''(1))
            show rhs: "LK_σ23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉' : 
              op_cf HomO.Cα𝔄(-,a) CF LK23 𝔗 CF 𝔉' :
              cat_ordinal (3) ↦↦Cα op_cat (cat_Set α)"
              by
                (
                  cs_concl
                    cs_simp: cat_Kan_cs_simps 
                    cs_intro: cat_Kan_cs_intros cat_cs_intros
                )
            from lhs have dom_lhs: "𝒟 (σNTMap) = 3"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)
            from rhs have dom_rhs:
              "𝒟 (LK_σ23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉'NTMap) = 3"
              by (cs_concl cs_simp: cat_ordinal_cs_simps cat_cs_simps)

            show "σNTMap = LK_σ23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉'NTMap"
            proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
              fix c assume "c  3"
              then consider c = 0 | c = 1 | c = 2 
                unfolding three by auto
              from this 0123 show 
                "σNTMapc =
                  LK_σ23 (op_cf HomO.Cα𝔄(-,a) CF 𝔗) η' 𝔉'NTMapc"
                by (cases, use nothing in simp_all only:)
                  (
                    cs_concl
                      cs_simp:
                        cat_ordinal_cs_simps
                        cat_cs_simps
                        cat_Kan_cs_simps
                        cat_op_simps
                        η'_NTMap_app_0
                        LK_σ23_NTMap_app_0
                        η'_NTMap_app_1
                      cs_intro: 
                        cat_ordinal_cs_intros
                        cat_Kan_cs_intros
                        cat_cs_intros
                        cat_op_intros
                        nat_omega_intros
                  )+
            qed (cs_concl cs_simp: cs_intro: cat_Kan_cs_intros V_cs_intros)+

          qed simp_all

        qed

      qed

      then have 
        "op_ntcf (HomO.Cα𝔄(-,a) CF-NTCF op_ntcf (ntcf_id 𝔗)) :
          op_cf (HomO.Cα𝔄(-,a) CF op_cf 𝔗) CF.lKeα
          op_cf ((HomO.Cα𝔄(-,a) CF op_cf (LK23 𝔗))) CF op_cf (op_cf 𝔎23) :
          op_cat (op_cat (cat_ordinal (2))) C
          op_cat (op_cat (cat_ordinal (3))) C
          op_cat (cat_Set α)"
        by
          (
            cs_concl
              cs_simp: cat_op_simps 
              cs_intro: cat_cs_intros cat_Kan_cs_intros cat_op_intros
          )
      from is_cat_lKe.is_cat_rKe_op[OF this] prems show
        "HomO.Cα𝔄(-,a) CF-NTCF op_ntcf (ntcf_id 𝔗) :
          (HomO.Cα𝔄(-,a) CF op_cf (LK23 𝔗)) CF op_cf 𝔎23 CF.rKeα
          HomO.Cα𝔄(-,a) CF op_cf 𝔗 :
          op_cat (cat_ordinal (2)) C 
          op_cat (cat_ordinal (3)) C
          cat_Set α"
        by
          (
            cs_prems
              cs_simp: cat_op_simps 
              cs_intro: cat_Kan_cs_intros cat_cs_intros cat_op_intros
          )

    qed

  qed

qed

text‹\newpage›

end

Theory CZH_UCAT_Conclusions

(* Copyright 2021 (C) Mihails Milehins *)

theory CZH_UCAT_Conclusions
  imports 
    CZH_UCAT_Universal
    CZH_UCAT_Limit
    CZH_UCAT_Complete
    CZH_UCAT_Adjoints
    CZH_UCAT_Kan
    CZH_UCAT_PWKan
    CZH_UCAT_PWKan_Example
begin
end